DGPHIST ;WASH/ERC - PURPLE HEART REQUEST HISTORY ;23 AUG 00
;;5.3;Registration;**343**,Aug 13, 1993
;
;This report will show the Purple Heart Request history on a patient
Q
;
EN ;Entry point
N DGDFN,DGPAT,DGNAM,DGSSN
S DGDFN=$$GETDFN()
Q:DGDFN'>0
S DGPAT=$$GETPAT(DGDFN)
Q:$P(DGPAT,U)=""
S DGNAM=$P(DGPAT,U),DGSSN=$P(DGPAT,U,2)
I '$$PH(DGDFN) D Q
. W !!,"There is no Purple Heart history for patient "_$G(DGNAM)_"."
. W !
. I $E(IOST,1,2)="C-" K DIR S DIR(0)="E" D ^DIR K DIR
I $$DEVICE() D START
D EXIT
Q
;
GETDFN() ;Ask the user to select patient
;
; Input: none
;
; Output: DFN
;
N DIC,X,Y
S DIC="^DPT(",DIC(0)="AEMQ"
D ^DIC
Q $S(+Y>0:+Y,1:0)
;
GETPAT(DFN) ; get patient name and ssn
;
; Input: DFN - patient IEN
;
; Output:
; Function value: patient name^SSN
;
N VADM,DGNAM,DGSSN
S (DGNAM,DGSSN)=""
I $G(DFN)>0 D
. D ^VADPT
. S DGNAM=VADM(1)
. S DGSSN=$P(VADM(2),U,2)
Q DGNAM_"^"_DGSSN
;
PH(DGDFN1) ; does patient PH history exist
;
; Input: DGDFN1 - Patient IEN
;
; Output:
; Function value: 0 - No PH Status history
; >0 - History exists
;
Q $P($G(^DPT(DGDFN1,"PH",0)),U,3)>0
;
DEVICE() ;select output device
;
; Input: none
;
; Output: Function value Interpretation
; 0 User decides to queue or not print report.
; 1 Device selected to generate report NOW.
;
N OK,IOP,POP,%ZIS
S OK=1
S %ZIS="MQ"
D ^%ZIS
S:POP OK=0
I OK,$D(IO("Q")) D
. N ZTRTN,ZTDESC,ZTSAVE,ZTSK
. S ZTRTN="START^DGPHIST"
. S ZTDESC="Current PH Status Pending/In Process report."
. S ZTSAVE("DGDFN")=""
. S ZTSAVE("DGNAM")=""
. S ZTSAVE("DGSSN")=""
. F DG1=1:1:20 D ^%ZTLOAD Q:$G(ZTSK)
. W !,$S($D(ZTSK):"Request "_ZTSK_" Queued!",1:"Request Cancelled!"),!
. D HOME^%ZIS
. S OK=0
Q OK
;
START ;
U IO
N DGSITE,DGSTNUM,DGSTN,DGSTTN,DGDTN
S DGSITE=$$SITE^VASITE
S DGSTNUM=$P(DGSITE,U,3),DGSTN=$P(DGSITE,U,2)
S DGSTTN=$$NAME^VASITE(DT)
S DGDTN=$S($G(DGSTTN)]"":DGSTTN,1:$G(DGSTN))
D DATA
D EXIT
Q
;
DATA ;Build line data and print
;
; Division name retrieved from pointer to the INSTITUTION file (#4)
; in PH DIVISION field (#.535) of PATIENT file (#2).
; DBIA: #10090 - Supported read to the INSTITUTION file with FileMan
;
N DGLINE,DGDATE,DGIND,DGSTAT,DGREM,DGUSER
N DGQUIT,DGPAGE,DGDIV
N DG1,DG2
S (DGPAGE,DGQUIT)=0
S DGDIV=$$GET1^DIQ(2,DGDFN,.535)
D HEAD
S DG1=0
F S DG1=$O(^DPT(DGDFN,"PH",DG1)) Q:DG1'>0 D
. S DGLINE(DG1)=^DPT(DGDFN,"PH",DG1,0)
S DG2=0
F S DG2=$O(DGLINE(DG2)) Q:DG2'>0 D
. D:$Y>(IOSL-4) HEAD Q:DGQUIT
. S DGDATE=$P($P(DGLINE(DG2),U),".")
. S DGDATE=$E(DGDATE,4,5)_"/"_$E(DGDATE,6,7)_"/"_$E(($E(DGDATE,1,3)+1700),3,4)
. S DGIND=$P(DGLINE(DG2),U,2)
. S DGIND=$S($G(DGIND)="Y":"Yes",$G(DGIND)="N":"No",1:"Unk")
. S DGSTAT=$P(DGLINE(DG2),U,3)
. S DGSTAT=$S($G(DGSTAT)="1":"Pending",$G(DGSTAT)="2":"In Process",$G(DGSTAT)="3":"Confirmed",1:"")
. S DGREM=$P(DGLINE(DG2),U,4)
. S DGREM=$S($G(DGREM)=1:"UNACCEPTABLE DOCUMENTATION",$G(DGREM)=2:"NO DOCUMENTATION REC'D",$G(DGREM)=3:"ENTERED IN ERROR",$G(DGREM)=4:"UNSUPPORTED PURPLE HEART",$G(DGREM)=5:"VAMC",$G(DGREM)=6:"UNDELIVERABLE MAIL",1:"")
. S DGUSER=$P(DGLINE(DG2),U,5)
. I $G(DGSTAT)["2"!($G(DGSTAT)["3") S DGUSER="HEC User"
. I $G(DGREM)]"",($G(DGREM)'["VAMC") S DGUSER="HEC User"
. W !,$G(DGDATE),?10,$G(DGIND),?15,$G(DGSTAT),?27,$G(DGREM),?55,$E($G(DGUSER),1,24)
W !!?30,"End of Report."
W !
I $E(IOST,1,2)="C-" K DIR S DIR(0)="E" D ^DIR K DIR
Q
HEAD ; page header
N DGDT
I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQUIT)=1 Q
I $G(DGPAGE)>0 I $E(IOST,1,2)="C-" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1
Q:DGQUIT
W @IOF
S Y=DT X ^DD("DD") S DGDT=Y
S DGPAGE=$G(DGPAGE)+1
W !!,"PURPLE HEART REQUEST HISTORY REPORT",?48,DGDT,?70,"Page: ",$G(DGPAGE)
W !,"STATION: "_$G(DGSTN)
I DGDIV]"" W !,"DIVISION: ",DGDIV
W !,"_____________________________________________________________________________"
W !!,"Patient Name: "_$G(DGNAM),?55,"SSN: "_$G(DGSSN)
W !,"-----------------------------------------------------------------------------"
W !!,"Date",?10,"PH?",?15,"Status",?27,"Remarks",?55,"Updated By"
W !,"--------",?10,"---",?15,"----------",?27,"--------------------------",?55,"---------------"
Q
;
EXIT ;
I $D(ZTQUEUED) S ZTREQ="@"
I '$D(ZTQUEUED) D
. K %ZIS,POP
. D ^%ZISC,HOME^%ZIS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPHIST 4511 printed Apr 09, 2024@22:01:23 Page 2
DGPHIST ;WASH/ERC - PURPLE HEART REQUEST HISTORY ;23 AUG 00
+1 ;;5.3;Registration;**343**,Aug 13, 1993
+2 ;
+3 ;This report will show the Purple Heart Request history on a patient
+4 QUIT
+5 ;
EN ;Entry point
+1 NEW DGDFN,DGPAT,DGNAM,DGSSN
+2 SET DGDFN=$$GETDFN()
+3 if DGDFN'>0
QUIT
+4 SET DGPAT=$$GETPAT(DGDFN)
+5 if $PIECE(DGPAT,U)=""
QUIT
+6 SET DGNAM=$PIECE(DGPAT,U)
SET DGSSN=$PIECE(DGPAT,U,2)
+7 IF '$$PH(DGDFN)
Begin DoDot:1
+8 WRITE !!,"There is no Purple Heart history for patient "_$GET(DGNAM)_"."
+9 WRITE !
+10 IF $EXTRACT(IOST,1,2)="C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+11 IF $$DEVICE()
DO START
+12 DO EXIT
+13 QUIT
+14 ;
GETDFN() ;Ask the user to select patient
+1 ;
+2 ; Input: none
+3 ;
+4 ; Output: DFN
+5 ;
+6 NEW DIC,X,Y
+7 SET DIC="^DPT("
SET DIC(0)="AEMQ"
+8 DO ^DIC
+9 QUIT $SELECT(+Y>0:+Y,1:0)
+10 ;
GETPAT(DFN) ; get patient name and ssn
+1 ;
+2 ; Input: DFN - patient IEN
+3 ;
+4 ; Output:
+5 ; Function value: patient name^SSN
+6 ;
+7 NEW VADM,DGNAM,DGSSN
+8 SET (DGNAM,DGSSN)=""
+9 IF $GET(DFN)>0
Begin DoDot:1
+10 DO ^VADPT
+11 SET DGNAM=VADM(1)
+12 SET DGSSN=$PIECE(VADM(2),U,2)
End DoDot:1
+13 QUIT DGNAM_"^"_DGSSN
+14 ;
PH(DGDFN1) ; does patient PH history exist
+1 ;
+2 ; Input: DGDFN1 - Patient IEN
+3 ;
+4 ; Output:
+5 ; Function value: 0 - No PH Status history
+6 ; >0 - History exists
+7 ;
+8 QUIT $PIECE($GET(^DPT(DGDFN1,"PH",0)),U,3)>0
+9 ;
DEVICE() ;select output device
+1 ;
+2 ; Input: none
+3 ;
+4 ; Output: Function value Interpretation
+5 ; 0 User decides to queue or not print report.
+6 ; 1 Device selected to generate report NOW.
+7 ;
+8 NEW OK,IOP,POP,%ZIS
+9 SET OK=1
+10 SET %ZIS="MQ"
+11 DO ^%ZIS
+12 if POP
SET OK=0
+13 IF OK
IF $DATA(IO("Q"))
Begin DoDot:1
+14 NEW ZTRTN,ZTDESC,ZTSAVE,ZTSK
+15 SET ZTRTN="START^DGPHIST"
+16 SET ZTDESC="Current PH Status Pending/In Process report."
+17 SET ZTSAVE("DGDFN")=""
+18 SET ZTSAVE("DGNAM")=""
+19 SET ZTSAVE("DGSSN")=""
+20 FOR DG1=1:1:20
DO ^%ZTLOAD
if $GET(ZTSK)
QUIT
+21 WRITE !,$SELECT($DATA(ZTSK):"Request "_ZTSK_" Queued!",1:"Request Cancelled!"),!
+22 DO HOME^%ZIS
+23 SET OK=0
End DoDot:1
+24 QUIT OK
+25 ;
START ;
+1 USE IO
+2 NEW DGSITE,DGSTNUM,DGSTN,DGSTTN,DGDTN
+3 SET DGSITE=$$SITE^VASITE
+4 SET DGSTNUM=$PIECE(DGSITE,U,3)
SET DGSTN=$PIECE(DGSITE,U,2)
+5 SET DGSTTN=$$NAME^VASITE(DT)
+6 SET DGDTN=$SELECT($GET(DGSTTN)]"":DGSTTN,1:$GET(DGSTN))
+7 DO DATA
+8 DO EXIT
+9 QUIT
+10 ;
DATA ;Build line data and print
+1 ;
+2 ; Division name retrieved from pointer to the INSTITUTION file (#4)
+3 ; in PH DIVISION field (#.535) of PATIENT file (#2).
+4 ; DBIA: #10090 - Supported read to the INSTITUTION file with FileMan
+5 ;
+6 NEW DGLINE,DGDATE,DGIND,DGSTAT,DGREM,DGUSER
+7 NEW DGQUIT,DGPAGE,DGDIV
+8 NEW DG1,DG2
+9 SET (DGPAGE,DGQUIT)=0
+10 SET DGDIV=$$GET1^DIQ(2,DGDFN,.535)
+11 DO HEAD
+12 SET DG1=0
+13 FOR
SET DG1=$ORDER(^DPT(DGDFN,"PH",DG1))
if DG1'>0
QUIT
Begin DoDot:1
+14 SET DGLINE(DG1)=^DPT(DGDFN,"PH",DG1,0)
End DoDot:1
+15 SET DG2=0
+16 FOR
SET DG2=$ORDER(DGLINE(DG2))
if DG2'>0
QUIT
Begin DoDot:1
+17 if $Y>(IOSL-4)
DO HEAD
if DGQUIT
QUIT
+18 SET DGDATE=$PIECE($PIECE(DGLINE(DG2),U),".")
+19 SET DGDATE=$EXTRACT(DGDATE,4,5)_"/"_$EXTRACT(DGDATE,6,7)_"/"_$EXTRACT(($EXTRACT(DGDATE,1,3)+1700),3,4)
+20 SET DGIND=$PIECE(DGLINE(DG2),U,2)
+21 SET DGIND=$SELECT($GET(DGIND)="Y":"Yes",$GET(DGIND)="N":"No",1:"Unk")
+22 SET DGSTAT=$PIECE(DGLINE(DG2),U,3)
+23 SET DGSTAT=$SELECT($GET(DGSTAT)="1":"Pending",$GET(DGSTAT)="2":"In Process",$GET(DGSTAT)="3":"Confirmed",1:"")
+24 SET DGREM=$PIECE(DGLINE(DG2),U,4)
+25 SET DGREM=$SELECT($GET(DGREM)=1:"UNACCEPTABLE DOCUMENTATION",$GET(DGREM)=2:"NO DOCUMENTATION REC'D",$GET(DGREM)=3:"ENTERED IN ERROR",$GET(DGREM)=4:"UNSUPPORTED PURPLE HEART",$GET(DGREM)=5:"VAMC",$GET(DGREM)=6:"UNDELIVERABLE MAIL",1:"")
+26 SET DGUSER=$PIECE(DGLINE(DG2),U,5)
+27 IF $GET(DGSTAT)["2"!($GET(DGSTAT)["3")
SET DGUSER="HEC User"
+28 IF $GET(DGREM)]""
IF ($GET(DGREM)'["VAMC")
SET DGUSER="HEC User"
+29 WRITE !,$GET(DGDATE),?10,$GET(DGIND),?15,$GET(DGSTAT),?27,$GET(DGREM),?55,$EXTRACT($GET(DGUSER),1,24)
End DoDot:1
+30 WRITE !!?30,"End of Report."
+31 WRITE !
+32 IF $EXTRACT(IOST,1,2)="C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
+33 QUIT
HEAD ; page header
+1 NEW DGDT
+2 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (ZTSTOP,DGQUIT)=1
QUIT
+3 IF $GET(DGPAGE)>0
IF $EXTRACT(IOST,1,2)="C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if +Y=0
SET DGQUIT=1
+4 if DGQUIT
QUIT
+5 WRITE @IOF
+6 SET Y=DT
XECUTE ^DD("DD")
SET DGDT=Y
+7 SET DGPAGE=$GET(DGPAGE)+1
+8 WRITE !!,"PURPLE HEART REQUEST HISTORY REPORT",?48,DGDT,?70,"Page: ",$GET(DGPAGE)
+9 WRITE !,"STATION: "_$GET(DGSTN)
+10 IF DGDIV]""
WRITE !,"DIVISION: ",DGDIV
+11 WRITE !,"_____________________________________________________________________________"
+12 WRITE !!,"Patient Name: "_$GET(DGNAM),?55,"SSN: "_$GET(DGSSN)
+13 WRITE !,"-----------------------------------------------------------------------------"
+14 WRITE !!,"Date",?10,"PH?",?15,"Status",?27,"Remarks",?55,"Updated By"
+15 WRITE !,"--------",?10,"---",?15,"----------",?27,"--------------------------",?55,"---------------"
+16 QUIT
+17 ;
EXIT ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+3 KILL %ZIS,POP
+4 DO ^%ZISC
DO HOME^%ZIS
End DoDot:1
+5 QUIT
