APCLDOD2 ; IHS/CMI/LAB - INFANT FEEDING REPORT #1 ;
;;2.0;IHS PCC SUITE;**8**;MAY 14, 2009;Build 2
;
;
;
EP ;EP - called from option interactive
D EOJ
W:$D(IOF) @IOF
S APCLTEXT="INTROT" F APCLJ=1:1 S APCLX=$T(@APCLTEXT+APCLJ) Q:$P(APCLX,";;",2)="END" S APCLT=$P(APCLX,";;",2) W !,APCLT
WPAT ;
S APCLALLD=""
S DIR(0)="S^A:ALL Patients with Date of Death Recorded;D:A Range of Dates for DOD;O:One PATIENT"
S DIR("A")="Which Date of Death Date range",DIR("B")="A" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D EOJ Q
S APCLALLD=Y
I APCLALLD="A" S (APCLBD,APCLSD)=1010101,APCLED=DT G SORTR
I APCLALLD="O" D G:'APCLDFN WPAT G ZIS
.K DIC S DIC=2,DIC("A")="Select Patient: ",DIC(0)="AEMQ" D ^DIC
.I Y=-1 Q
.I $$DOD^AUPNPAT(+Y)="" W !!,"That patient has no DOD recorded." H 2 G WPAT
.S APCLDFN=+Y
GETDATES ;
BD ;get beginning date
W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter beginning Date of Death" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G EOJ
S APCLBD=Y
ED ;get ending date
K DIR W ! S DIR(0)="DA^"_APCLBD_":DT:EP",DIR("A")="Enter ending Date of Death: " D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G BD
S APCLED=Y
S X1=APCLBD,X2=-1 D C^%DTC S APCLSD=X
;
SORTR ;
S APCLSORT=""
S DIR(0)="S^D:Date of Death;H:HRN;R:Terminal Digit HRN;C:Community;T:Tribe;N:Patient Name",DIR("A")="Sort Report by",DIR("B")="D" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G WPAT
S APCLSORT=Y
ZIS ;
DEMO ;
D DEMOCHK^APCLUTL(.APCLDEMO)
I APCLDEMO=-1 G SORTR
S XBRP="PRINT^APCLDOD2",XBRC="PROC^APCLDOD2",XBRX="EOJ^APCLDOD2",XBNS="APCL"
D ^XBDBQUE
Q
EOJ ;
D ^XBFMK
K DIC,DIR
D EN^XBVK("APCL")
Q
;
PROC ;
S APCLJ=$J,APCLH=$H
S ^XTMP("APCLDOD2",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"DATE OF DEATH REPORT"
I APCLALLD="O" S X=$$SORT(APCLDFN,"N") S ^XTMP("APCLDOD2",APCLJ,APCLH,"PTS",X,DFN)="" Q
S APCLSD=APCLSD_".9999"
S DFN=0 F S APCLSD=$O(^DPT("AEXP1",APCLSD)) Q:APCLSD'=+APCLSD!($P(APCLSD,".")>APCLED) D
.S DFN=0 F S DFN=$O(^DPT("AEXP1",APCLSD,DFN)) Q:DFN'=+DFN D
..Q:'$D(^DPT(DFN))
..Q:'$D(^AUPNPAT(DFN))
..Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
..S X=$$SORT(DFN,APCLSORT)
..I X="" S X="---"
..S ^XTMP("APCLDOD2",APCLJ,APCLH,"PTS",X,DFN)=""
..Q
Q
DONE ;
I $E(IOST)="C",IO=IO(0) S DIR(0)="EO",DIR("A")="End of report. PRESS ENTER" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
;W:$D(IOF) @IOF
K APCLTS,APCLS,APCLM,APCLET
K ^XTMP("APCLDOD2",APCLJ,APCLH),APCLJ,APCLH
Q
;
;
PRINT ;EP - called from xbdbque
S APCLQ=0,APCLPG=0
D HEADER
S APCLSV="" F S APCLSV=$O(^XTMP("APCLDOD2",APCLJ,APCLH,"PTS",APCLSV)) Q:APCLSV=""!(APCLQ) D
.S DFN=0 F S DFN=$O(^XTMP("APCLDOD2",APCLJ,APCLH,"PTS",APCLSV,DFN)) Q:DFN'=+DFN!(APCLQ) D
..S Y=DFN D ^AUPNPAT
..I $Y>(IOSL-3) D HEADER Q:APCLQ
..W !,$E($P(^DPT(DFN,0),U),1,23),?25,$$HRN^AUPNPAT(DFN,DUZ(2)),?32,$$D($P(^DPT(DFN,0),U,3)),?45,$$AGE^AUPNPAT(DFN,AUPNDOD)
..W ?50,$$D(AUPNDOD),?61,$E($$VAL^XBDIQ1(9000001,DFN,1108),1,18)
..W !?2,"Underlying Cause of Death: ",$$VAL^XBDIQ1(9000001,DFN,1114)
..W !?2,"Last Visit: ",$$LASTVD(DFN,AUPNDOB,AUPNDOD)
..W !?2,"Last Inpatient Visit: ",$$LASTVD(DFN,AUPNDOB,AUPNDOD,1)
..W !?2,"Community of Residence: ",$$VAL^XBDIQ1(9000001,DFN,1118)
..Q
.Q
Q
LASTVD(P,BDATE,EDATE,H) ;
K ^TMP($J,"A")
S H=$G(H)
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S (X,G)="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G) S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:'$D(^AUPNVPRV("AD",V))
.Q:"SAHORI"'[$P(^AUPNVSIT(V,0),U,7)
.I H,$P(^AUPNVSIT(V,0),U,7)'="H" Q
.S G=V
.Q
I 'G Q ""
Q $$D($P($P(^AUPNVSIT(G,0),U),"."))_" "_$$VAL^XBDIQ1(9000010,V,.06)_" - "_$$VAL^XBDIQ1(9000010,V,.07)
G:'APCLPG HEADER1
K DIR I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLQ=1 Q
W:$D(IOF) @IOF S APCLPG=APCLPG+1
W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",APCLPG,!
W $$CTR($P(^DIC(4,DUZ(2),0),U),80),!
W !,$$CTR("DECEASED PATIENTS REPORT",80),!
I '$G(APCLDFN) S X="Date of Death: "_$$FMTE^XLFDT(APCLBD)_" - "_$$FMTE^XLFDT(APCLED) W $$CTR(X,80),!
W !,"Patient Name",?25,"HRN",?32,"DOB",?43,"Age at",?50,"DOD",?61,"Tribe"
W !?43,"Death"
W !,$TR($J("",80)," ","-")
Q
D(D) ;
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))
C(X,X2,X3) ;
D COMMA^%DTC
Q X
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
SORT(P,S) ;
NEW R
S R=""
D @(S_"SORT")
I R="" S R="ZZZZZZZZ"
Q R
;
DSORT ;
S R=$$VALI^XBDIQ1(2,P,.351)
Q
CSORT ;
S X=$$VAL^XBDIQ1(9000001,P,1118)
Q
TSORT ;
S R=$$VAL^XBDIQ1(9000001,P,1108)
Q
NSORT ;
S R=$$VAL^XBDIQ1(2,P,.01)
Q
;
HSORT ;
S R=$$HRN^AUPNPAT(P,DUZ(2))
Q
;
RSORT ;
S R=$$HRN^AUPNPAT(P,DUZ(2))
S R=R+10000000,R=$E(R,7,8)_$E(R,1,6)
Q
INTROT ;
;; DECEASED PATIENT LISTING
;;
;;This option will produce a report of all patients who have a Date of
;;Death entered into RPMS. You can limit the range of dates or get
;;all patients with a DOD recorded. You can optionally choose just
;;one patient.
;;
;;The report can be sorted by either HRN, Terminal Digit HRN, Date of
;;Death, Community, Tribe, or Patient Name.
;;
;;END
APCLDOD2 ; IHS/CMI/LAB - INFANT FEEDING REPORT #1 ;
+1 ;;2.0;IHS PCC SUITE;**8**;MAY 14, 2009;Build 2
+2 ;
+3 ;
+4 ;
EP ;EP - called from option interactive
+1 DO EOJ
+2 IF $DATA(IOF)
WRITE @IOF
+3 SET APCLTEXT="INTROT"
FOR APCLJ=1:1
SET APCLX=$TEXT(@APCLTEXT+APCLJ)
IF $PIECE(APCLX,";;",2)="END"
QUIT
SET APCLT=$PIECE(APCLX,";;",2)
WRITE !,APCLT
WPAT ;
+1 SET APCLALLD=""
+2 SET DIR(0)="S^A:ALL Patients with Date of Death Recorded;D:A Range of Dates for DOD;O:One PATIENT"
+3 SET DIR("A")="Which Date of Death Date range"
SET DIR("B")="A"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
DO EOJ
QUIT
+5 SET APCLALLD=Y
+6 IF APCLALLD="A"
SET (APCLBD,APCLSD)=1010101
SET APCLED=DT
GOTO SORTR
+7 IF APCLALLD="O"
Begin DoDot:1
+8 KILL DIC
SET DIC=2
SET DIC("A")="Select Patient: "
SET DIC(0)="AEMQ"
DO ^DIC
+9 IF Y=-1
QUIT
+10 IF $$DOD^AUPNPAT(+Y)=""
WRITE !!,"That patient has no DOD recorded."
HANG 2
GOTO WPAT
+11 SET APCLDFN=+Y
End DoDot:1
IF 'APCLDFN
GOTO WPAT
GOTO ZIS
GETDATES ;
BD ;get beginning date
+1 WRITE !
SET DIR(0)="D^:DT:EP"
SET DIR("A")="Enter beginning Date of Death"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO EOJ
+3 SET APCLBD=Y
ED ;get ending date
+1 KILL DIR
WRITE !
SET DIR(0)="DA^"_APCLBD_":DT:EP"
SET DIR("A")="Enter ending Date of Death: "
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO BD
+3 SET APCLED=Y
+4 SET X1=APCLBD
SET X2=-1
DO C^%DTC
SET APCLSD=X
+5 ;
SORTR ;
+1 SET APCLSORT=""
+2 SET DIR(0)="S^D:Date of Death;H:HRN;R:Terminal Digit HRN;C:Community;T:Tribe;N:Patient Name"
SET DIR("A")="Sort Report by"
SET DIR("B")="D"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO WPAT
+4 SET APCLSORT=Y
ZIS ;
DEMO ;
+1 DO DEMOCHK^APCLUTL(.APCLDEMO)
+2 IF APCLDEMO=-1
GOTO SORTR
+3 SET XBRP="PRINT^APCLDOD2"
SET XBRC="PROC^APCLDOD2"
SET XBRX="EOJ^APCLDOD2"
SET XBNS="APCL"
+4 DO ^XBDBQUE
+5 QUIT
EOJ ;
+1 DO ^XBFMK
+2 KILL DIC,DIR
+3 DO EN^XBVK("APCL")
+4 QUIT
+5 ;
PROC ;
+1 SET APCLJ=$JOB
SET APCLH=$HOROLOG
+2 SET ^XTMP("APCLDOD2",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"DATE OF DEATH REPORT"
+3 IF APCLALLD="O"
SET X=$$SORT(APCLDFN,"N")
SET ^XTMP("APCLDOD2",APCLJ,APCLH,"PTS",X,DFN)=""
QUIT
+4 SET APCLSD=APCLSD_".9999"
+5 SET DFN=0
FOR
SET APCLSD=$ORDER(^DPT("AEXP1",APCLSD))
IF APCLSD'=+APCLSD!($PIECE(APCLSD,".")>APCLED)
QUIT
Begin DoDot:1
+6 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("AEXP1",APCLSD,DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:2
+7 IF '$DATA(^DPT(DFN))
QUIT
+8 IF '$DATA(^AUPNPAT(DFN))
QUIT
+9 IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
QUIT
+10 SET X=$$SORT(DFN,APCLSORT)
+11 IF X=""
SET X="---"
+12 SET ^XTMP("APCLDOD2",APCLJ,APCLH,"PTS",X,DFN)=""
+13 QUIT
End DoDot:2
End DoDot:1
+14 QUIT
DONE ;
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
SET DIR(0)="EO"
SET DIR("A")="End of report. PRESS ENTER"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 ;W:$D(IOF) @IOF
+3 KILL APCLTS,APCLS,APCLM,APCLET
+4 KILL ^XTMP("APCLDOD2",APCLJ,APCLH),APCLJ,APCLH
+5 QUIT
+6 ;
+7 ;
PRINT ;EP - called from xbdbque
+1 SET APCLQ=0
SET APCLPG=0
+2 DO HEADER
+3 SET APCLSV=""
FOR
SET APCLSV=$ORDER(^XTMP("APCLDOD2",APCLJ,APCLH,"PTS",APCLSV))
IF APCLSV=""!(APCLQ)
QUIT
Begin DoDot:1
+4 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("APCLDOD2",APCLJ,APCLH,"PTS",APCLSV,DFN))
IF DFN'=+DFN!(APCLQ)
QUIT
Begin DoDot:2
+5 SET Y=DFN
DO ^AUPNPAT
+6 IF $Y>(IOSL-3)
DO HEADER
IF APCLQ
QUIT
+7 WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,23),?25,$$HRN^AUPNPAT(DFN,DUZ(2)),?32,$$D($PIECE(^DPT(DFN,0),U,3)),?45,$$AGE^AUPNPAT(DFN,AUPNDOD)
+8 WRITE ?50,$$D(AUPNDOD),?61,$EXTRACT($$VAL^XBDIQ1(9000001,DFN,1108),1,18)
+9 WRITE !?2,"Underlying Cause of Death: ",$$VAL^XBDIQ1(9000001,DFN,1114)
+10 WRITE !?2,"Last Visit: ",$$LASTVD(DFN,AUPNDOB,AUPNDOD)
+11 WRITE !?2,"Last Inpatient Visit: ",$$LASTVD(DFN,AUPNDOB,AUPNDOD,1)
+12 WRITE !?2,"Community of Residence: ",$$VAL^XBDIQ1(9000001,DFN,1118)
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 QUIT
LASTVD(P,BDATE,EDATE,H) ;
+1 KILL ^TMP($JOB,"A")
+2 SET H=$GET(H)
+3 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+4 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+5 SET (X,G)=""
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+8 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+9 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+10 IF "SAHORI"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+11 IF H
IF $PIECE(^AUPNVSIT(V,0),U,7)'="H"
QUIT
+12 SET G=V
+13 QUIT
End DoDot:1
+14 IF 'G
QUIT ""
+15 QUIT $$D($PIECE($PIECE(^AUPNVSIT(G,0),U),"."))_" "_$$VAL^XBDIQ1(9000010,V,.06)_" - "_$$VAL^XBDIQ1(9000010,V,.07)
+1 IF 'APCLPG
GOTO HEADER1
+2 KILL DIR
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCLQ=1
QUIT
+1 IF $DATA(IOF)
WRITE @IOF
SET APCLPG=APCLPG+1
+2 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",APCLPG,!
+3 WRITE $$CTR($PIECE(^DIC(4,DUZ(2),0),U),80),!
+4 WRITE !,$$CTR("DECEASED PATIENTS REPORT",80),!
+5 IF '$GET(APCLDFN)
SET X="Date of Death: "_$$FMTE^XLFDT(APCLBD)_" - "_$$FMTE^XLFDT(APCLED)
WRITE $$CTR(X,80),!
+6 WRITE !,"Patient Name",?25,"HRN",?32,"DOB",?43,"Age at",?50,"DOD",?61,"Tribe"
+7 WRITE !?43,"Death"
+8 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+9 QUIT
D(D) ;
+1 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+$EXTRACT(D,1,3))
C(X,X2,X3) ;
+1 DO COMMA^%DTC
+2 QUIT X
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
+3 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
SORT(P,S) ;
+1 NEW R
+2 SET R=""
+3 DO @(S_"SORT")
+4 IF R=""
SET R="ZZZZZZZZ"
+5 QUIT R
+6 ;
DSORT ;
+1 SET R=$$VALI^XBDIQ1(2,P,.351)
+2 QUIT
CSORT ;
+1 SET X=$$VAL^XBDIQ1(9000001,P,1118)
+2 QUIT
TSORT ;
+1 SET R=$$VAL^XBDIQ1(9000001,P,1108)
+2 QUIT
NSORT ;
+1 SET R=$$VAL^XBDIQ1(2,P,.01)
+2 QUIT
+3 ;
HSORT ;
+1 SET R=$$HRN^AUPNPAT(P,DUZ(2))
+2 QUIT
+3 ;
RSORT ;
+1 SET R=$$HRN^AUPNPAT(P,DUZ(2))
+2 SET R=R+10000000
SET R=$EXTRACT(R,7,8)_$EXTRACT(R,1,6)
+3 QUIT
INTROT ;
+1 ;; DECEASED PATIENT LISTING
+2 ;;
+3 ;;This option will produce a report of all patients who have a Date of
+4 ;;Death entered into RPMS. You can limit the range of dates or get
+5 ;;all patients with a DOD recorded. You can optionally choose just
+6 ;;one patient.
+7 ;;
+8 ;;The report can be sorted by either HRN, Terminal Digit HRN, Date of
+9 ;;Death, Community, Tribe, or Patient Name.
+10 ;;
+11 ;;END
