NUPAOBJ ;PHOENIX/KLD; 6/23/09; PULL PATIENT INFO; 1/11/12 8:38 AM
;;1.0;NUPA;;;Build 105
;;Object code taken from my R1TIOB package
;;IAs used: 2400, 3800, 4477
ST Q
;
MAR() ;Marital status
Q $$FLD("MARITAL STATUS^.05")
;
RELIG() ;Patient's Religious preference
Q $$FLD("RELIGION^.08")
;
FLD(Z) N X S X=$$GET1^DIQ(2,DFN,$P(Z,U,2)) Q $P(Z,U)_" - "_$S(X="":"NONE FOUND",1:X)
;
NVA(T) ;Active Non-VA Meds T=Time period^Condensed Version (0 for No or 1 for Yes)
N NUPA,X,X1,X2,Y D K,NONE("ACTIVE NON-VA MEDS"),AGO^NUPAOBJ1
S X1=NUPA("ED"),X2=-365 D C^%DTC S NUPA("ED",1)=X
S $P(NUPA("SP")," ",50)="",NUPA("C")=0
;Go back an additonal year in the next call to capture RXs dispensed then,
;who's days of supply would then extend into the proper time period.
D OCL^PSOORRL(DFN,NUPA("ED",1),DT,0) ;IA 2400
F NUPA("I")=0:0 S NUPA("I")=$O(^TMP("PS",$J,NUPA("I"))) Q:'NUPA("I") D
.S NUPA("TYPE")=$P(^TMP("PS",$J,NUPA("I"),0),U)
.Q:NUPA("TYPE")'["N;O" Q:$P(^TMP("PS",$J,NUPA("I"),0),U,9)'="ACTIVE" ;Non-VA Meds
.Q:$P(^TMP("PS",$J,NUPA("I"),0),U,2)["OTHER"
.S NUPA("ORD")=$P(^TMP("PS",$J,NUPA("I"),0),U,8)
.Q:$$GET1^DIQ(100,NUPA("ORD"),4,"I")<NUPA("ED") ;Order entered
.I $D(APGKAUTH) Q:$$GET1^DIQ(100,NUPA("ORD"),1,"I")'=DUZ
.I $D(APGKTODY) Q:$$GET1^DIQ(100,NUPA("ORD"),4,"I")'=DT ;Order entered
.S NUPA("C")=NUPA("C")+1
.S ^TMP("NUPA",$J,"SORT","N",$P(^TMP("PS",$J,NUPA("I"),0),U,2),NUPA("C"))=NUPA("ORD")_U_^TMP("PS",$J,NUPA("I"),"SIG",1,0)
S (NUPA("C"),NUPA("C",1))=0,NUPA("RX")=""
D:$D(^TMP("NUPA",$J,"SORT","N")) SET("*** NON-VA MEDS ***")
F S NUPA("RX")=$O(^TMP("NUPA",$J,"SORT","N",NUPA("RX"))) Q:NUPA("RX")="" D
.F NUPA("I")=0:0 S NUPA("I")=$O(^TMP("NUPA",$J,"SORT","N",NUPA("RX"),NUPA("I"))) Q:'NUPA("I") D
..S NUPA("C",1)=NUPA("C",1)+1 D SET($J(NUPA("C",1),2)_") "_NUPA("RX"))
..D SET(" "_$P(^TMP("NUPA",$J,"SORT","N",NUPA("RX"),NUPA("I")),U,2))
..S NUPA("ORD")=+^TMP("NUPA",$J,"SORT","N",NUPA("RX"),NUPA("I"))
..S NUPA("STATE")=0 S:'$P(T,U,2) NUPA("STATE")=$O(^OR(100,NUPA("ORD"),4.5,"ID","STATEMENTS",0))
..D:NUPA("STATE")
...F NUPA("II")=0:0 S NUPA("II")=$O(^OR(100,NUPA("ORD"),4.5,NUPA("STATE"),2,NUPA("II"))) Q:'NUPA("II") D
....D SET(^OR(100,NUPA("ORD"),4.5,NUPA("STATE"),2,NUPA("II"),0))
..D SET("")
K ^TMP("NUPA",$J,"SORT"),^TMP("PS",$J),APGKAUTH,APGKTODY
Q "~@^TMP(""NUPA"","_$J_")"
;
TO() ;Today's orders. Yesterday's also if desired (S NUPAYEST=""), or
;all orders (S NUPAALL="")
N A,C,ED,I,II,ORD,SD,SIG,SP,X S X="ORDERS TODAY"
S:$D(NUPAYEST) X="ORDERS YESTERDAY & TODAY" D K,NONE(X)
S $P(SP," ",30)="",A=DFN_";DPT(",C=2
S SD=$S($D(NUPAALL):1,1:(9999999-DT-1)) ;Inverse date for 1/1/1900 for all orders
S ED=$S($D(NUPAALL):9999999,1:(SD+1))
S:$D(NUPAYEST) ED=SD+2
F I=SD:0 S I=$O(^OR(100,"AC",A,I)) Q:'I!(I>ED) D
.F ORD=1:0 S ORD=$O(^OR(100,"AC",A,I,ORD)) Q:'ORD D
..Q:$$GET1^DIQ(100,ORD,2)["ALLERGY ENTER/EDIT"
..I $D(NUPAAUTH) Q:$$GET1^DIQ(100,ORD,1,"I")'=DUZ
..I $G(PKG) Q:$$GET1^DIQ(100,ORD,12,"I")'=PKG
..I $G(STAT) Q:$$GET1^DIQ(100,ORD,5)'=STAT
..;next IF is for text orders with no orderable items
..;IA 3800 allows direct global reads of ^OR(100,D0,.1
..I '$D(^OR(100,ORD,.1)) D TEXTORD
..F II=0:0 S II=$O(^OR(100,ORD,.1,II)) Q:'II D
...S X=$E($E($$GET1^DIQ(101.43,+^OR(100,ORD,.1,II,0),.01),1,22)_SP,1,25)
...S X=$E(X_$$D($P($$GET1^DIQ(100,ORD,21,"I"),"."))_SP,1,40)
...S X=X_$$D($P($$GET1^DIQ(100,ORD,22,"I"),"."))
...S X=$E(X_SP,1,55)_$$GET1^DIQ(100,ORD,4) D SET(X)
...I $D(NUPASIG) D ;Only display Sigs for Meds
....S X(1)=$$GET1^DIQ(100,ORD,23,"I")
....Q:$$GET1^DIQ(100.98,X(1),.01)'["MEDICATIONS"
....D SIG(ORD),SET(" Sig: "_SIG)
I C>2 S X=$E(" Item Ordered"_SP,1,25) D
.S C=0,X=$E(X_"START DATE"_SP,1,40)_"STOP DATE"
.S X=$E(X_SP,1,58)_"ENTERED" D SET(X),SET("")
K NUPAALL,NUPAAUTH,NUPASIG,NUPAYEST,PKG,STAT
Q "~@^TMP(""NUPA"","_$J_")"
TEXTORD N I,II,III,WP,X
F I=0:0 S I=$O(^OR(100,ORD,8,I)) Q:'I D
.S WP=$$GET1^DIQ(100.008,I_","_ORD,.1,"","WP")
.F II=0:0 S II=$O(WP(II)) Q:'II D
..S:II=1 X="Text Order: "
..I $L(WP(II))<64 D SET(X_WP(II)) S X="" Q
..F III=(75-$L(X)):-1:0 Q:$E(WP(II),III)=" "
..D SET(X_$E(WP(II),1,III)) S X=$E(WP(II),III+1,999)
..S:$E(X,$L(X))'=" " X=X_" "
D:$G(X)]"" SET(X) Q
;
SIG(N) N NUPAWP S NUPA("SIG")="None listed" S:N NUPA("SIG")=$O(^OR(100,N,4.5,"ID","SIG",0))
S NUPAWP=$$GET1^DIQ(100.045,NUPA("SIG")_","_N,2,"","NUPAWP")
S NUPA("SIG",1)=$G(NUPAWP(2)) S:NUPAWP(1)]"" NUPA("SIG")=NUPAWP(1)
I NUPA("SIG")="",N S NUPA("SIG")=$O(^OR(100,N,4.5,"ID","COMMENT",0)) D
.S NUPAWP=$$GET1^DIQ(100.045,NUPA("SIG")_","_N,2,"","NUPAWP")
.S NUPA("SIG",1)=$G(NUPAWP(2)) S:NUPAWP(1)]"" NUPA("SIG")=NUPAWP(1)
Q:NUPA("SIG")]"" S NUPA("SIG")=$O(^PSRX("APL",N,0)) Q:'NUPA("SIG")
S SIG=$$GET1^DIQ(52,NUPA("SIG"),10) Q
;
LADM(Z) ;Z=0 - |LAST ADMISSION DATE| Z=1 - |LAST ADMISSION|
;Z=2 - Return fileman date of admission
;Z=3 - Return fileman date of next to last admission
N NUPA,DA,X S X="LAST ADMISSION - NONE FOUND" Q:'$G(DFN) X
S NUPA("ADM")=$O(^DGPM("ATID1",DFN,0)) I 'NUPA("ADM") D NONE("LAST ADMISSION") Q $S(Z=2:0,1:X)
S DA=$O(^DGPM("ATID1",DFN,NUPA("ADM"),0)),NUPA("DIS")=$O(^DGPM("ATID3",DFN,0))
I Z=3 S DA="",NUPA("ADM")=$O(^DGPM("ATID1",DFN,NUPA("ADM"))) S:NUPA("ADM") DA=$O(^DGPM("ATID1",DFN,NUPA("ADM"),0))
S NUPA("ADM")=9999999.999999-NUPA("ADM") S:NUPA("DIS") NUPA("DIS")=9999999.999999-NUPA("DIS")
S X=$S(Z<2:"Last admission: "_$$D(NUPA("ADM")),1:NUPA("ADM"))
I Z=1 S X=X_" DX: "_$$GET1^DIQ(405,DA,.1) S:NUPA("DIS")>NUPA("ADM") X=X_" ** DISCHARGED **"
N X1,X2
I 23[Z S NUPA=X_U_DA,X1=DT,X2=$$GET1^DIQ(405,DA,.01,"I") D ^%DTC S X=NUPA_U_X_U_$$GET1^DIQ(405,DA,.1)
S:23[Z&(X["NONE FOUND") X=0 Q X
;
EC() ;Emergency Contact
N C,X S C=0 D K
D GETS^DIQ(2,DFN,".331;.332:.339;.33011","","X")
D SET(" Contact: "_$G(X(2,DFN_",",.331)))
D SET("Relationship: "_$G(X(2,DFN_",",.332)))
D SET(" Address: "_$G(X(2,DFN_",",.333)))
S X=$G(X(2,DFN_",",.334)) D:X]"" SET(" "_X)
S X=$G(X(2,DFN_",",.335)) D:X]"" SET(" "_X)
S X=$$GET1^DIQ(2,DFN,".337:1")
D SET(" "_$G(X(2,DFN_",",.336))_", "_X_" "_$G(X(2,DFN_",",.338)))
D SET(" Phone: "_$G(X(2,DFN_",",.339)))
D SET(" Work Phone: "_$G(X(2,DFN_",",.33011)))
Q "~@^TMP(""NUPA"","_$J_")"
;
LN(N,T) ;Last note. N=Note Title (or ANY), T=Time period
;IA 4477 - read C xref of file 8925
N C,DIC,ED,NUPA,NUPAWP,X S (C,NUPA("C"),NUPA("I",1),NUPA("NOTEDATE"))=0
D K,NONE("LAST NOTE ("_N_")"),AGO^NUPAOBJ1 G LNQ:'$G(DFN)
S NUPA("TITLE")=N I N'="ANY" S DIC="^TIU(8925.1,",DIC(0)="M",X=N D ^DIC S NUPA("TITLE")=+Y
I NUPA("TITLE")="" D SET(N_": INVALID NOTE TITLE") G LNQ
F NUPA("I")=9E9:0 S NUPA("I")=$O(^TIU(8925,"C",DFN,NUPA("I")),-1) Q:'NUPA("I")!(NUPA("NOTEDATE")) D
.I NUPA("TITLE")'="ANY" Q:$$GET1^DIQ(8925,NUPA("I"),.01,"I")'=NUPA("TITLE")
.S NUPA("NOTEDATE")=$$GET1^DIQ(8925,NUPA("I"),1201,"I") Q:+NUPA("NOTEDATE")<ED
.S:N="ANY" N="NOTE ("_$$GET1^DIQ(8925,NUPA("I"),.01)_")" S NUPA("I",1)=NUPA("I")
S:'NUPA("NOTEDATE") NUPA("NOTEDATE")="NONE" S:NUPA("NOTEDATE") NUPA("NOTEDATE")=$$D(NUPA("NOTEDATE"))
D SET("LAST "_N_": "_NUPA("NOTEDATE")_" (#"_NUPA("I",1)_")"),SET("")
I '$D(NUPANOTX) D:'$G(NUPA("I",1)) SET("NO TEXT FOUND") I $G(NUPA("I",1)) D
.S NUPAWP=$$GET1^DIQ(8925,NUPA("I",1),2,"","NUPAWP")
.F NUPA("II")=0:0 S NUPA("II")=$O(NUPAWP(NUPA("II"))) Q:'NUPA("II") D SET(NUPAWP(NUPA("II")))
LNQ K NUPANOTX Q "~@^TMP(""NUPA"","_$J_")"
;
K K ^TMP("NUPA",$J) Q
NONE(X) S ^TMP("NUPA",$J,1,0)=X_" - NONE FOUND" Q
SET(X) S:$G(C)&('$G(NUPA("C"))) NUPA("C")=C S NUPA("C")=$G(NUPA("C"))+1,^TMP("NUPA",$J,NUPA("C"),0)=X Q
D(Y) D DD^%DT Q Y
D1(Y) Q +$E(Y,4,5)_"/"_+$E(Y,6,7)_"/"_$E(Y,2,3)_" @ "_$E($P(Y,".",2)_"0000",1,4)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNUPAOBJ 7857 printed Sep 23, 2025@19:59:51 Page 2
NUPAOBJ ;PHOENIX/KLD; 6/23/09; PULL PATIENT INFO; 1/11/12 8:38 AM
+1 ;;1.0;NUPA;;;Build 105
+2 ;;Object code taken from my R1TIOB package
+3 ;;IAs used: 2400, 3800, 4477
ST QUIT
+1 ;
MAR() ;Marital status
+1 QUIT $$FLD("MARITAL STATUS^.05")
+2 ;
RELIG() ;Patient's Religious preference
+1 QUIT $$FLD("RELIGION^.08")
+2 ;
FLD(Z) NEW X
SET X=$$GET1^DIQ(2,DFN,$PIECE(Z,U,2))
QUIT $PIECE(Z,U)_" - "_$SELECT(X="":"NONE FOUND",1:X)
+1 ;
NVA(T) ;Active Non-VA Meds T=Time period^Condensed Version (0 for No or 1 for Yes)
+1 NEW NUPA,X,X1,X2,Y
DO K
DO NONE("ACTIVE NON-VA MEDS")
DO AGO^NUPAOBJ1
+2 SET X1=NUPA("ED")
SET X2=-365
DO C^%DTC
SET NUPA("ED",1)=X
+3 SET $PIECE(NUPA("SP")," ",50)=""
SET NUPA("C")=0
+4 ;Go back an additonal year in the next call to capture RXs dispensed then,
+5 ;who's days of supply would then extend into the proper time period.
+6 ;IA 2400
DO OCL^PSOORRL(DFN,NUPA("ED",1),DT,0)
+7 FOR NUPA("I")=0:0
SET NUPA("I")=$ORDER(^TMP("PS",$JOB,NUPA("I")))
if 'NUPA("I")
QUIT
Begin DoDot:1
+8 SET NUPA("TYPE")=$PIECE(^TMP("PS",$JOB,NUPA("I"),0),U)
+9 ;Non-VA Meds
if NUPA("TYPE")'["N;O"
QUIT
if $PIECE(^TMP("PS",$JOB,NUPA("I"),0),U,9)'="ACTIVE"
QUIT
+10 if $PIECE(^TMP("PS",$JOB,NUPA("I"),0),U,2)["OTHER"
QUIT
+11 SET NUPA("ORD")=$PIECE(^TMP("PS",$JOB,NUPA("I"),0),U,8)
+12 ;Order entered
if $$GET1^DIQ(100,NUPA("ORD"),4,"I")<NUPA("ED")
QUIT
+13 IF $DATA(APGKAUTH)
if $$GET1^DIQ(100,NUPA("ORD"),1,"I")'=DUZ
QUIT
+14 ;Order entered
IF $DATA(APGKTODY)
if $$GET1^DIQ(100,NUPA("ORD"),4,"I")'=DT
QUIT
+15 SET NUPA("C")=NUPA("C")+1
+16 SET ^TMP("NUPA",$JOB,"SORT","N",$PIECE(^TMP("PS",$JOB,NUPA("I"),0),U,2),NUPA("C"))=NUPA("ORD")_U_^TMP("PS",$JOB,NUPA("I"),"SIG",1,0)
End DoDot:1
+17 SET (NUPA("C"),NUPA("C",1))=0
SET NUPA("RX")=""
+18 if $DATA(^TMP("NUPA",$JOB,"SORT","N"))
DO SET("*** NON-VA MEDS ***")
+19 FOR
SET NUPA("RX")=$ORDER(^TMP("NUPA",$JOB,"SORT","N",NUPA("RX")))
if NUPA("RX")=""
QUIT
Begin DoDot:1
+20 FOR NUPA("I")=0:0
SET NUPA("I")=$ORDER(^TMP("NUPA",$JOB,"SORT","N",NUPA("RX"),NUPA("I")))
if 'NUPA("I")
QUIT
Begin DoDot:2
+21 SET NUPA("C",1)=NUPA("C",1)+1
DO SET($JUSTIFY(NUPA("C",1),2)_") "_NUPA("RX"))
+22 DO SET(" "_$PIECE(^TMP("NUPA",$JOB,"SORT","N",NUPA("RX"),NUPA("I")),U,2))
+23 SET NUPA("ORD")=+^TMP("NUPA",$JOB,"SORT","N",NUPA("RX"),NUPA("I"))
+24 SET NUPA("STATE")=0
if '$PIECE(T,U,2)
SET NUPA("STATE")=$ORDER(^OR(100,NUPA("ORD"),4.5,"ID","STATEMENTS",0))
+25 if NUPA("STATE")
Begin DoDot:3
+26 FOR NUPA("II")=0:0
SET NUPA("II")=$ORDER(^OR(100,NUPA("ORD"),4.5,NUPA("STATE"),2,NUPA("II")))
if 'NUPA("II")
QUIT
Begin DoDot:4
+27 DO SET(^OR(100,NUPA("ORD"),4.5,NUPA("STATE"),2,NUPA("II"),0))
End DoDot:4
End DoDot:3
+28 DO SET("")
End DoDot:2
End DoDot:1
+29 KILL ^TMP("NUPA",$JOB,"SORT"),^TMP("PS",$JOB),APGKAUTH,APGKTODY
+30 QUIT "~@^TMP(""NUPA"","_$JOB_")"
+31 ;
TO() ;Today's orders. Yesterday's also if desired (S NUPAYEST=""), or
+1 ;all orders (S NUPAALL="")
+2 NEW A,C,ED,I,II,ORD,SD,SIG,SP,X
SET X="ORDERS TODAY"
+3 if $DATA(NUPAYEST)
SET X="ORDERS YESTERDAY & TODAY"
DO K
DO NONE(X)
+4 SET $PIECE(SP," ",30)=""
SET A=DFN_";DPT("
SET C=2
+5 ;Inverse date for 1/1/1900 for all orders
SET SD=$SELECT($DATA(NUPAALL):1,1:(9999999-DT-1))
+6 SET ED=$SELECT($DATA(NUPAALL):9999999,1:(SD+1))
+7 if $DATA(NUPAYEST)
SET ED=SD+2
+8 FOR I=SD:0
SET I=$ORDER(^OR(100,"AC",A,I))
if 'I!(I>ED)
QUIT
Begin DoDot:1
+9 FOR ORD=1:0
SET ORD=$ORDER(^OR(100,"AC",A,I,ORD))
if 'ORD
QUIT
Begin DoDot:2
+10 if $$GET1^DIQ(100,ORD,2)["ALLERGY ENTER/EDIT"
QUIT
+11 IF $DATA(NUPAAUTH)
if $$GET1^DIQ(100,ORD,1,"I")'=DUZ
QUIT
+12 IF $GET(PKG)
if $$GET1^DIQ(100,ORD,12,"I")'=PKG
QUIT
+13 IF $GET(STAT)
if $$GET1^DIQ(100,ORD,5)'=STAT
QUIT
+14 ;next IF is for text orders with no orderable items
+15 ;IA 3800 allows direct global reads of ^OR(100,D0,.1
+16 IF '$DATA(^OR(100,ORD,.1))
DO TEXTORD
+17 FOR II=0:0
SET II=$ORDER(^OR(100,ORD,.1,II))
if 'II
QUIT
Begin DoDot:3
+18 SET X=$EXTRACT($EXTRACT($$GET1^DIQ(101.43,+^OR(100,ORD,.1,II,0),.01),1,22)_SP,1,25)
+19 SET X=$EXTRACT(X_$$D($PIECE($$GET1^DIQ(100,ORD,21,"I"),"."))_SP,1,40)
+20 SET X=X_$$D($PIECE($$GET1^DIQ(100,ORD,22,"I"),"."))
+21 SET X=$EXTRACT(X_SP,1,55)_$$GET1^DIQ(100,ORD,4)
DO SET(X)
+22 ;Only display Sigs for Meds
IF $DATA(NUPASIG)
Begin DoDot:4
+23 SET X(1)=$$GET1^DIQ(100,ORD,23,"I")
+24 if $$GET1^DIQ(100.98,X(1),.01)'["MEDICATIONS"
QUIT
+25 DO SIG(ORD)
DO SET(" Sig: "_SIG)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+26 IF C>2
SET X=$EXTRACT(" Item Ordered"_SP,1,25)
Begin DoDot:1
+27 SET C=0
SET X=$EXTRACT(X_"START DATE"_SP,1,40)_"STOP DATE"
+28 SET X=$EXTRACT(X_SP,1,58)_"ENTERED"
DO SET(X)
DO SET("")
End DoDot:1
+29 KILL NUPAALL,NUPAAUTH,NUPASIG,NUPAYEST,PKG,STAT
+30 QUIT "~@^TMP(""NUPA"","_$JOB_")"
TEXTORD NEW I,II,III,WP,X
+1 FOR I=0:0
SET I=$ORDER(^OR(100,ORD,8,I))
if 'I
QUIT
Begin DoDot:1
+2 SET WP=$$GET1^DIQ(100.008,I_","_ORD,.1,"","WP")
+3 FOR II=0:0
SET II=$ORDER(WP(II))
if 'II
QUIT
Begin DoDot:2
+4 if II=1
SET X="Text Order: "
+5 IF $LENGTH(WP(II))<64
DO SET(X_WP(II))
SET X=""
QUIT
+6 FOR III=(75-$LENGTH(X)):-1:0
if $EXTRACT(WP(II),III)=" "
QUIT
+7 DO SET(X_$EXTRACT(WP(II),1,III))
SET X=$EXTRACT(WP(II),III+1,999)
+8 if $EXTRACT(X,$LENGTH(X))'=" "
SET X=X_" "
End DoDot:2
End DoDot:1
+9 if $GET(X)]""
DO SET(X)
QUIT
+10 ;
SIG(N) NEW NUPAWP
SET NUPA("SIG")="None listed"
if N
SET NUPA("SIG")=$ORDER(^OR(100,N,4.5,"ID","SIG",0))
+1 SET NUPAWP=$$GET1^DIQ(100.045,NUPA("SIG")_","_N,2,"","NUPAWP")
+2 SET NUPA("SIG",1)=$GET(NUPAWP(2))
if NUPAWP(1)]""
SET NUPA("SIG")=NUPAWP(1)
+3 IF NUPA("SIG")=""
IF N
SET NUPA("SIG")=$ORDER(^OR(100,N,4.5,"ID","COMMENT",0))
Begin DoDot:1
+4 SET NUPAWP=$$GET1^DIQ(100.045,NUPA("SIG")_","_N,2,"","NUPAWP")
+5 SET NUPA("SIG",1)=$GET(NUPAWP(2))
if NUPAWP(1)]""
SET NUPA("SIG")=NUPAWP(1)
End DoDot:1
+6 if NUPA("SIG")]""
QUIT
SET NUPA("SIG")=$ORDER(^PSRX("APL",N,0))
if 'NUPA("SIG")
QUIT
+7 SET SIG=$$GET1^DIQ(52,NUPA("SIG"),10)
QUIT
+8 ;
LADM(Z) ;Z=0 - |LAST ADMISSION DATE| Z=1 - |LAST ADMISSION|
+1 ;Z=2 - Return fileman date of admission
+2 ;Z=3 - Return fileman date of next to last admission
+3 NEW NUPA,DA,X
SET X="LAST ADMISSION - NONE FOUND"
if '$GET(DFN)
QUIT X
+4 SET NUPA("ADM")=$ORDER(^DGPM("ATID1",DFN,0))
IF 'NUPA("ADM")
DO NONE("LAST ADMISSION")
QUIT $SELECT(Z=2:0,1:X)
+5 SET DA=$ORDER(^DGPM("ATID1",DFN,NUPA("ADM"),0))
SET NUPA("DIS")=$ORDER(^DGPM("ATID3",DFN,0))
+6 IF Z=3
SET DA=""
SET NUPA("ADM")=$ORDER(^DGPM("ATID1",DFN,NUPA("ADM")))
if NUPA("ADM")
SET DA=$ORDER(^DGPM("ATID1",DFN,NUPA("ADM"),0))
+7 SET NUPA("ADM")=9999999.999999-NUPA("ADM")
if NUPA("DIS")
SET NUPA("DIS")=9999999.999999-NUPA("DIS")
+8 SET X=$SELECT(Z<2:"Last admission: "_$$D(NUPA("ADM")),1:NUPA("ADM"))
+9 IF Z=1
SET X=X_" DX: "_$$GET1^DIQ(405,DA,.1)
if NUPA("DIS")>NUPA("ADM")
SET X=X_" ** DISCHARGED **"
+10 NEW X1,X2
+11 IF 23[Z
SET NUPA=X_U_DA
SET X1=DT
SET X2=$$GET1^DIQ(405,DA,.01,"I")
DO ^%DTC
SET X=NUPA_U_X_U_$$GET1^DIQ(405,DA,.1)
+12 if 23[Z&(X["NONE FOUND")
SET X=0
QUIT X
+13 ;
EC() ;Emergency Contact
+1 NEW C,X
SET C=0
DO K
+2 DO GETS^DIQ(2,DFN,".331;.332:.339;.33011","","X")
+3 DO SET(" Contact: "_$GET(X(2,DFN_",",.331)))
+4 DO SET("Relationship: "_$GET(X(2,DFN_",",.332)))
+5 DO SET(" Address: "_$GET(X(2,DFN_",",.333)))
+6 SET X=$GET(X(2,DFN_",",.334))
if X]""
DO SET(" "_X)
+7 SET X=$GET(X(2,DFN_",",.335))
if X]""
DO SET(" "_X)
+8 SET X=$$GET1^DIQ(2,DFN,".337:1")
+9 DO SET(" "_$GET(X(2,DFN_",",.336))_", "_X_" "_$GET(X(2,DFN_",",.338)))
+10 DO SET(" Phone: "_$GET(X(2,DFN_",",.339)))
+11 DO SET(" Work Phone: "_$GET(X(2,DFN_",",.33011)))
+12 QUIT "~@^TMP(""NUPA"","_$JOB_")"
+13 ;
LN(N,T) ;Last note. N=Note Title (or ANY), T=Time period
+1 ;IA 4477 - read C xref of file 8925
+2 NEW C,DIC,ED,NUPA,NUPAWP,X
SET (C,NUPA("C"),NUPA("I",1),NUPA("NOTEDATE"))=0
+3 DO K
DO NONE("LAST NOTE ("_N_")")
DO AGO^NUPAOBJ1
if '$GET(DFN)
GOTO LNQ
+4 SET NUPA("TITLE")=N
IF N'="ANY"
SET DIC="^TIU(8925.1,"
SET DIC(0)="M"
SET X=N
DO ^DIC
SET NUPA("TITLE")=+Y
+5 IF NUPA("TITLE")=""
DO SET(N_": INVALID NOTE TITLE")
GOTO LNQ
+6 FOR NUPA("I")=9E9:0
SET NUPA("I")=$ORDER(^TIU(8925,"C",DFN,NUPA("I")),-1)
if 'NUPA("I")!(NUPA("NOTEDATE"))
QUIT
Begin DoDot:1
+7 IF NUPA("TITLE")'="ANY"
if $$GET1^DIQ(8925,NUPA("I"),.01,"I")'=NUPA("TITLE")
QUIT
+8 SET NUPA("NOTEDATE")=$$GET1^DIQ(8925,NUPA("I"),1201,"I")
if +NUPA("NOTEDATE")<ED
QUIT
+9 if N="ANY"
SET N="NOTE ("_$$GET1^DIQ(8925,NUPA("I"),.01)_")"
SET NUPA("I",1)=NUPA("I")
End DoDot:1
+10 if 'NUPA("NOTEDATE")
SET NUPA("NOTEDATE")="NONE"
if NUPA("NOTEDATE")
SET NUPA("NOTEDATE")=$$D(NUPA("NOTEDATE"))
+11 DO SET("LAST "_N_": "_NUPA("NOTEDATE")_" (#"_NUPA("I",1)_")")
DO SET("")
+12 IF '$DATA(NUPANOTX)
if '$GET(NUPA("I",1))
DO SET("NO TEXT FOUND")
IF $GET(NUPA("I",1))
Begin DoDot:1
+13 SET NUPAWP=$$GET1^DIQ(8925,NUPA("I",1),2,"","NUPAWP")
+14 FOR NUPA("II")=0:0
SET NUPA("II")=$ORDER(NUPAWP(NUPA("II")))
if 'NUPA("II")
QUIT
DO SET(NUPAWP(NUPA("II")))
End DoDot:1
LNQ KILL NUPANOTX
QUIT "~@^TMP(""NUPA"","_$JOB_")"
+1 ;
K KILL ^TMP("NUPA",$JOB)
QUIT
NONE(X) SET ^TMP("NUPA",$JOB,1,0)=X_" - NONE FOUND"
QUIT
SET(X) if $GET(C)&('$GET(NUPA("C")))
SET NUPA("C")=C
SET NUPA("C")=$GET(NUPA("C"))+1
SET ^TMP("NUPA",$JOB,NUPA("C"),0)=X
QUIT
D(Y) DO DD^%DT
QUIT Y
D1(Y) QUIT +$EXTRACT(Y,4,5)_"/"_+$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_" @ "_$EXTRACT($PIECE(Y,".",2)_"0000",1,4)
