VistA-FOIAVistA/r/SPINAL_CORD_DYSFUNCTION-SPN/SPNPRT01.m

74 lines
2.4 KiB
Mathematica

SPNPRT01 ;HIRMFO/WAA- PRINT Mailing Labels ; 8/21/96
;;2.0;Spinal Cord Dysfunction;**11,15**;01/02/1997
;This routine is to store mailing labels into a file.
;
EN1 ; Main Entry Point
N SPNLEXIT,SPNIO,SPNPAGE S SPNPAGE=1
S SPNLEXIT=0 D EN1^SPNPRTMT Q:SPNLEXIT ;Filters
S ZTSAVE("SPN*")=""
D DEVICE^SPNPRTMT("PRINT^SPNPRT01","SCD Mailing Labels",.ZTSAVE) Q:SPNLEXIT
I SPNIO="Q" D EXIT Q ; Print was Queued
I IO'="" D PRINT D EXIT Q ; Print was not Queued
Q
EXIT ; Exit routine
K SPNLEXIT,SPNIO,SPNPAGE
K ^TMP($J,"SPN"),^TMP($J,"SPNPRT","AUTO"),^TMP($J,"SPNPRT","POST")
Q
PRINT ; Print main Body
U IO
S SPNLEXIT=$G(SPNLEXIT) ; Ensure that exit is set; **MOD CM/SD ,0
N SPNDFN,SPNX
I $E(IOST,1)="C" D Q:SPNLEXIT
.W !,"Prepare to capture list: Hit return when you are ready: "
.W !,"When you see ---END--- Close the capture file and hit return."
.R !,SPNX:DTIME I '$T S SPNX="^"
.I SPNX="^" S SPNLEXIT=1 Q
.Q
;W "NAME,ADDRESS1,ADDRESS2,ADDRESS3,CITY,STATE,ZIPCODE"
W "FNAME,LNAME,ADDRESS1,ADDRESS2,ADDRESS3,CITY,STATE,ZIPCODE"
S (SPNDFN,SPNLPRT)=0
F S SPNDFN=$O(^SPNL(154,SPNDFN)) Q:SPNDFN<1 D Q:SPNLEXIT
. N LINE,SPNPRT
. S SPNPRT=0
. Q:SPNLEXIT
. Q:$G(^SPNL(154,SPNDFN,0))="" ; No Zero node
. I $L($$GET1^DIQ(2,SPNDFN_",",.351)) Q ;Patient has passed on WDE
. Q:$P(^SPNL(154,SPNDFN,0),"^",3)="X" ; **MOD CM/SD No expired pts
. I '$$EN2^SPNPRTMT(SPNDFN) Q ; Patient fail the filters
. S SPNLPRT=1 ; Indicates the report had data
. S DFN=SPNDFN D ^VADPT
. ;S LINE=""_$P(VADM(1),",",2)_" "_$P(VADM(1),",",1)_"" ; **MOD CM/SD
. S LINE=""_$P($P(VADM(1),",",2)," ",1)_"" ; first name
. S LINE=LINE_","_$P(VADM(1),",",1) ; last name
. S DFN=SPNDFN D ADD^VADPT
. I VAPA(1)=""!(VAPA(4)="")!($P(VAPA(5),U,2)="")!(VAPA(6)="") S SPNPRT=1
. F I=1:1:4 D
.. S:VAPA(I)["," VAPA(I)=""""_VAPA(I)_""""
.. S LINE=LINE_","_VAPA(I)
.. Q
. S LINE=$S($P(VAPA(5),U,1)'="":LINE_","_$P($G(^DIC(5,$P(VAPA(5),U,1),0)),U,2),1:LINE_","_"UNKNOWN") ; **MOD CM/SD STATE
. S LINE=LINE_","_VAPA(6)
. I 'SPNPRT W !,LINE
. D KVAR^VADPT
. Q
I 'SPNLPRT W !," ******* No Data for this report. *******"
I $E(IOST,1)="C" D
.R !,"---END---",SPNX:DTIME
.Q
D CLOSE^SPNPRTMT
Q
HEAD ; Header Print
I SPNPAGE'=1 Q:$Y<(IOSL-4)
I $E(IOST,1)="C" D Q:SPNLEXIT
.I SPNPAGE=1 W @IOF Q
.I SPNPAGE'=1 D Q:SPNLEXIT
..N DIR S DIR(0)="E" D ^DIR I 'Y S SPNLEXIT=1
..K Y
..Q
.Q
Q:SPNLEXIT
I SPNPAGE'=1 W @IOF
S SPNPAGE=SPNPAGE+1
I $D(ZTQUEUED) S:$$STPCK^SPNPRTMT SPNLEXIT=1
Q