NUPAOBJ1 ;PHOENIX/KLD; 6/23/09; PULL PATIENT INFO; 1/11/12 8:38 AM
;;1.0;NUPA;;;Build 105
;;Object code taken from my NUPAOB package
;;IAs used: 2400, 4245, 4246, 4791, 5047
ST Q
;
BMI(N) ;Body Mass Index |BMI;N;nY|
N NUPA,X S NUPA("T")=$P(N,U,2),NUPA("N")=+$G(N,1)
S:NUPA("T")="" NUPA("T")="2Y"
D AGO S NUPA("ED")=ED,NUPA("AGO")=9999999-NUPA("ED"),NUPA("C")=0,X="BODY MASS INDEX" D K,NONE(X)
S NUPA("BMI")="",NUPA("C")=0,X=$$VIS(NUPA("N"),NUPA("T"),8)
F NUPA("I")=0:0 S NUPA("I")=$O(^TMP("NUPA",$J,NUPA("I"))) Q:'NUPA("I") D
.S NUPA("C")=NUPA("C")+1,NUPA("HT",NUPA("I"))=^TMP("NUPA",$J,NUPA("I"),0)
S:NUPA("C")=1&('$P($G(NUPA("HT",1)),U,2)) NUPA("C")=0 ;Invalid height
I 'NUPA("C") D SET(X_" - NO HEIGHTS FOUND") G BMIQ
S NUPA("C")=0,X=$$VIS(NUPA("N"),NUPA("T"),9)
F NUPA("I")=0:0 S NUPA("I")=$O(^TMP("NUPA",$J,NUPA("I"))) Q:'NUPA("I") D
.S NUPA("C")=NUPA("C")+1,NUPA("WT",NUPA("I"))=^TMP("NUPA",$J,NUPA("I"),0)
S:NUPA("C")=1&('$P($G(NUPA("WT",1)),U,2)) NUPA("C")=0 ;Invalid weight
I 'NUPA("C") D SET(X_" - NO WEIGHTS FOUND") G BMIQ
S NUPA("C")=0 ;D:NUPA("N")>1 SET(X)
F NUPA("I")=1:1:NUPA("N") D:$D(NUPA("WT",NUPA("I")))
.S NUPA("HT")=0 S:$P($G(NUPA("HT",NUPA("I"))),U,2) NUPA("HT")=$P(NUPA("HT",NUPA("I")),U,2) S NUPA("WT")=$P(NUPA("WT",NUPA("I")),U,2)
.S NUPA("H")=NUPA("HT")*.0254,NUPA("H")=NUPA("H")*NUPA("H"),NUPA("WT")=NUPA("WT")/2.2,X=$$D(+NUPA("WT",NUPA("I"))) ;_" "
.S:NUPA("H") X=$J((NUPA("WT")/NUPA("H")),4,1)_" ("_X_")"
.D:NUPA("N")=1 SET("BODY MASS INDEX - "_X) D:NUPA("N")>1 SET(" "_X)
BMIQ Q "~@^TMP(""NUPA"","_$J_")"
;
AM(N) ;Active meds, OP, IV, UD. N=number of days back
N NUPA,X,X1,X2,Y S:$G(N)="" N=45 S $P(NUPA("SP")," ",50)="",X1=DT,X2=-N
D C^%DTC S NUPA("AGO")=X,X1=DT,X2=(-N-365) D C^%DTC S NUPA("AGO",1)=X
S NUPA("C")=0 D K,NONE("ACTIVE MEDS")
;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("AGO",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)
.I NUPA("TYPE")[";I" Q:$P(^TMP("PS",$J,NUPA("I"),0),U,4)<NUPA("AGO") ;IV/Unit Dose
.I NUPA("TYPE")["N;O" Q:$P(^TMP("PS",$J,NUPA("I"),0),U,9)'="ACTIVE" ;Non-VA Meds
.I NUPA("TYPE")["R;O" S X1=$P(^TMP("PS",$J,NUPA("I"),0),U,10),X2=$P(^TMP("PS",$J,NUPA("I"),0),U,11) D C^%DTC Q:X<NUPA("AGO") ;OP RX Last Dispense date + Days supply not in range
.S NUPA("C")=NUPA("C")+1
.S X=$S(NUPA("TYPE")["N;O":"N",NUPA("TYPE")["R;O":"O",NUPA("TYPE")["U;I":"U",NUPA("TYPE")["V;I":"V",1:"UNK")
.S ^TMP("NUPA",$J,"SORT",X,$P(^TMP("PS",$J,NUPA("I"),0),U,2),NUPA("C"))=$P(^TMP("PS",$J,NUPA("I"),0),U,10,11)_U_$P(^TMP("PS",$J,NUPA("I"),0),U,4)_U_NUPA("TYPE")
S NUPA("C")=0
F NUPA("SUB")="O","V","U" D
.D SET("*** "_$S(NUPA("SUB")="O":"Outpatient",NUPA("SUB")="V":"IV",1:"Unit Dose")_" ***")
.D:'$D(^TMP("NUPA",$J,"SORT",NUPA("SUB"))) NF S NUPA("RX")=""
.F S NUPA("RX")=$O(^TMP("NUPA",$J,"SORT",NUPA("SUB"),NUPA("RX"))) Q:NUPA("RX")="" D
..F NUPA("I")=0:0 S NUPA("I")=$O(^TMP("NUPA",$J,"SORT",NUPA("SUB"),NUPA("RX"),NUPA("I"))) Q:'NUPA("I") D
...S X=" Drug: "_($E(NUPA("RX")_NUPA("SP"),1,45))
...S:NUPA("SUB")="O" X=X_" Last Dispensed: "_$$D($P(^TMP("NUPA",$J,"SORT",NUPA("SUB"),NUPA("RX"),NUPA("I")),U))_" ("_$P(^TMP("NUPA",$J,"SORT",NUPA("SUB"),NUPA("RX"),NUPA("I")),U,2)_" days)"
...S:NUPA("SUB")'="O" X=X_" Stop Date: "_$$D($P(^TMP("NUPA",$J,"SORT",NUPA("SUB"),NUPA("RX"),NUPA("I")),U,3))
...D SET(X)
K ^TMP("NUPA",$J,"SORT"),^TMP("PS",$J)
Q "~@^TMP(""NUPA"","_$J_")"
;
ONE(X) ;Single lab test in a time period object.
;X should be "Data name^# of occurances^time period (nM, nD, or nY)"
;or X could be "Print string^# of occurances^time period (nM, nD, or nY)^Data name number^Print completed time"
N NUPA S NUPA("TN")=X,C=0,$P(NUPA("SP")," ",50)=""
S NUPA("N")=$P(NUPA("TN"),U,2),NUPA("T")=$P(NUPA("TN"),U,3)
S:'NUPA("N") NUPA("N")=99 S:NUPA("T")="" NUPA("T")="99Y"
S:'$P(NUPA("TN"),U,4) NUPA("TEST")=$O(^DD(63.04,"B",$P(NUPA("TN"),U),0))
S:$P(NUPA("TN"),U,4) NUPA("TEST")=$P(NUPA("TN"),U,4)
I 'NUPA("TEST") D Q "~@^TMP(""NUPA"","_$J_")"
.D K S ^TMP("NUPA",$J,1,0)=$P(NUPA("TN"),U)_" - INVALID TEST NAME"
F NUPA("I")=1:1:NUPA("N") S NUPA("TEST",NUPA("I"))=0,NUPA("TEST",NUPA("I"),NUPA("TEST"))=""
S X=$$TEST^LRPXAPIU(NUPA("TEST")),NUPA("VALIDTESTS",X)=NUPA("TEST"),NUPA("VALIDTESTS","B",NUPA("TEST"))=X ;IA 4246
S (NUPA("CHK",1),NUPA("CHK",2))=NUPA("TEST") D GET
I NUPA("TEST",1) S X=$E($P(NUPA("TN"),U)_NUPA("SP"),1,26)_" " D
.I 'NUPA("TEST",1) S X=X_" NO DATA ON FILE" D SET(X) Q
.F NUPA("I")=1:1:NUPA("N")-1 D:NUPA("TEST",NUPA("I"))
..S X=$S(NUPA("I")=1:X,1:$E(NUPA("SP"),1,27))_$$D1(NUPA("TEST",NUPA("I")))_NUPA("SP")
..S X=$E(X,1,45)_$P(NUPA("TEST",NUPA("I"),NUPA("CHK",1)),U)_" "_$P(NUPA("TEST",NUPA("I"),NUPA("CHK",1)),U,2)
..S:$P(NUPA("TN"),U,5) X=$E(X_NUPA("SP"),1,55)_$$CONV2($P(NUPA("TEST",NUPA("I")),U,2))
..D SET(X)
D:$P(NUPA("TN"),U,5) ;also display Verify Date
.F NUPA("I")=9E9:0 S NUPA("I")=$O(^TMP("NUPA",$J,NUPA("I")),-1) Q:'NUPA("I") D
..S ^TMP("NUPA",$J,NUPA("I")+2,0)=^TMP("NUPA",$J,NUPA("I"),0)
.S ^TMP("NUPA",$J,1,0)=" TEST COLLECTION DATE RESULT VERIFY DATE"
.S ^TMP("NUPA",$J,2,0)=""
ONEQ Q "~@^TMP(""NUPA"","_$J_")"
;
GET ;Get data from ^LR(DFN,"CH")
N NUPATEST,ED,LRDFN,T,X S T=NUPA("T") D K,NONE($P(NUPA("TN"),U)),AGO S NUPA("ED")=ED
S NUPA("N")=1,LRDFN=$$GETL() Q:'LRDFN
D RESULTS^LRPXAPI(.NUPATEST,DFN,"C",999,"","",DT,NUPA("ED")) ;IA 4245
F NUPA("I")=0:0 S NUPA("I")=$O(NUPA("VALIDTESTS",NUPA("I"))) Q:'NUPA("I") D
.S NUPA("VALIDTESTS","B",NUPA("VALIDTESTS",NUPA("I")))=NUPA("I")
S X="" F S X=$O(NUPATEST(X)) Q:X="" D
.Q:'$P(NUPATEST(X),U,2) Q:'$D(NUPA("VALIDTESTS",$P(NUPATEST(X),U,2)))
.S ^TMP("NUPA",$J,"SORT",-NUPATEST(X),$P(NUPATEST(X),U,2))=$P(NUPATEST(X),U,4,5)
F NUPA("I")=-9E9:0 S NUPA("I")=$O(^TMP("NUPA",$J,"SORT",NUPA("I"))) Q:'NUPA("I") D
.S NUPA("FLAG")=0
.F NUPA("II")=0:0 S NUPA("II")=$O(^TMP("NUPA",$J,"SORT",NUPA("I"),NUPA("II"))) Q:'NUPA("II") D
..Q:'$D(^TMP("NUPA",$J,"SORT",NUPA("I"),NUPA("VALIDTESTS","B",NUPA("CHK",1))))!('$D(^TMP("NUPA",$J,"SORT",NUPA("I"),NUPA("VALIDTESTS","B",NUPA("CHK",2)))))
..S NUPA("TEST")=NUPA("VALIDTESTS",NUPA("II")) Q:'$D(NUPA("TEST",NUPA("N"),NUPA("TEST")))
..S:'NUPA("TEST",NUPA("N"),NUPA("TEST")) NUPA("TEST",NUPA("N"),NUPA("TEST"))=^TMP("NUPA",$J,"SORT",NUPA("I"),NUPA("II")),NUPA("FLAG")=1
.S:NUPA("FLAG") NUPA("TEST",NUPA("N"))=-NUPA("I"),NUPA("N")=NUPA("N")+1
K ^TMP("NUPA",$J,"SORT") Q
;
GETL() ;Get LRDFN
S DFN=+$G(DFN) Q $$LRDFN^LRPXAPIU(DFN) ;IA 4246
;
CONV() Q $$CONV2($$LRIDT^LRPXAPIU(NUPA("TEST",NUPA("I")))) ;IA 4246
CONV2(X) N XX S XX=$E($P(X,".",2)_"0000",1,4)
S X=X_$E(XX,1,2)_":"_$E(XX,3,4)
S X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)_" @ "
S X=X_$E(XX,1,2)_":"_$E(XX,3,4) Q X
;
VIS(NUPAHOWMANY,NUPABACK,NUPATYPE,NUPAQUALIFERS) ;
;NUPAHOWMANY Should be set to how many results you want back
;NUPABACK should contain the starting date to go back to
;NUPATYPE Is the vital ien that you want to report on this is in file (#120.51) NOTE THIS CAN LOOK LIKE "1;2;8;22"
;NUPAQUALIFERS Set this to 1 if you want to see the Qualifiers in the output
; 0: Date, description, value, no qualifiers
; 1: Date, description, value, qualifiers
; 2: Value, date, qualifiers, no description
; 3: Description, value, date, no qualifiers
; 4: Description, value, date, qualifiers
;You must have the users DFN in your table before calling the VIS tag.
N C,ED,I,II,X,X1,X2,NUPACNT,NUPAREVDT,NUPAIEN,NUPAFIELDS,NUPAPIECE1,NUPAPIECE2,NUPASPACE,NUPATEMP,NUPAZZ,GMRVSTR
S (C,NUPACNT)=0
K ^UTILITY($J,"GMRVD")
;------------------------------------
S NUPAALL=NUPATYPE F NUPALOOP=1:1 S NUPATYPE=$P(NUPAALL,";",NUPALOOP) Q:NUPATYPE="" D V2
;-------------------------------------
S X=$$FIELD^GMVGETVT(NUPATYPE,1,"E")
I $D(^UTILITY($J,"GMRVD"))=0 S X="No "_$S(X=-1:"",1:X)_"vitals found." D SET(X) ;IA 5047
K NUPACNT,NUPAREVDT,NUPAIEN,NUPAFIELDS,NUPAPIECE1,NUPAPIECE2,NUPASPACE,NUPATEMP,NUPAZZ
K NUPAHOWMANY,NUPABACK,NUPATYPE,NUPAQUALIFERS,NUPAALL,NUPALOOP
K ^UTILITY($J,"GMRVD")
Q "~@^TMP(""NUPA"","_$J_")"
;-------------------------------------
V2 ;
K NUPAVITNAM,T,ED,NUPAFIELDS,NUPATEMP,NUPAZZ,X
D K K ^UTILITY($J,"GMRVD")
S NUPAVITNAM=$$FIELD^GMVGETVT(NUPATYPE,2,"I") ;IA 5047
I $G(NUPAVITNAM)="" S X="No Vital type on file" D SET(X) Q
S T=NUPABACK D AGO
S GMRVSTR=NUPAVITNAM,GMRVSTR(0)=ED_"^"_(DT+.9999)_"^"_NUPAHOWMANY_"^"_1
D EN1^GMVHS ;IA 4791
S NUPAREVDT="" F S NUPAREVDT=$O(^UTILITY($J,"GMRVD",NUPAREVDT)) Q:(NUPAREVDT="")!('+NUPAREVDT) D
.S NUPACNT=NUPACNT+1
.S NUPAIEN=0 F S NUPAIEN=$O(^UTILITY($J,"GMRVD",NUPAREVDT,NUPAVITNAM,NUPAIEN)) Q:(NUPAIEN="")!('+NUPAIEN) D BUILD
Q
BUILD ;
K NUPAFIELDS
S NUPAFIELDS(.01)="2"
S NUPAFIELDS(5)=5
D EN^GMVPXRM(.NUPAFIELDS,NUPAIEN,"B")
S NUPAPIECE1=$S($D(NUPA("BMI")):+$G(NUPAFIELDS(1)),1:$P($G(NUPAFIELDS(1)),U,2)) ;$$FMTE^XLFDT($P($G(NUPAFIELDS(1)),U,1),"5"))
S NUPAPIECE2=$S($D(NUPA("BMI")):"",1:$P($G(NUPAFIELDS(3)),U,2)_": ")_$P($G(NUPAFIELDS(7)),U,2)
S NUPASPACE=$J("",35-$L(NUPAPIECE1))
I $G(NUPASORT)="VIT" S ^TMP("NUPA",$J,"PRE",NUPAREVDT,NUPAPIECE1,NUPATYPE,0)=$P($G(NUPAPIECE2),":",2) Q
I $G(NUPASORT)="PVI" S ^TMP("NUPA",$J,"PRE",NUPAREVDT,NUPAPIECE1,NUPATYPE,0)=$P($G(NUPAPIECE2),":",2) Q
D:$G(NUPAQUALIFERS)<2
.S:$D(NUPA("BMI")) X=NUPAPIECE1_U_NUPAPIECE2
.S:'$D(NUPA("BMI")) X=$E(NUPAPIECE1_NUPASPACE,1,24)_NUPAPIECE2_$$KG() D SET(X)
I $G(NUPAQUALIFERS)=2 S X=$E($P(NUPAPIECE2,": ",2)_$$KG()_NUPASPACE,1,24)_NUPAPIECE1 D SET(X)
I $G(NUPAQUALIFERS)=3!($G(NUPAQUALIFERS)=4) S X=$E(NUPAPIECE2_$$KG()_NUPASPACE,1,24)_NUPAPIECE1 D SET(X)
S NUPATEMP="" K X
S NUPAZZ=0 F S NUPAZZ=$O(NUPAFIELDS(12,NUPAZZ)) Q:(NUPAZZ="")!('+NUPAZZ) D
.Q:$G(NUPAFIELDS(12,NUPAZZ))="^"
.I NUPAZZ>1 S NUPATEMP=NUPATEMP_", "
.S NUPATEMP=NUPATEMP_$P($G(NUPAFIELDS(12,NUPAZZ)),U,2)
Q:'$G(NUPAQUALIFERS)!($G(NUPAQUALIFERS)=3)
;I $G(NUPAQUALIFERS)=1,$L(NUPATEMP)>1
S X=" Qualifier"_$S(NUPATEMP[",":"s: ",1:": ")_NUPATEMP D SET(X)
I NUPAFIELDS(3)["PULSE OX" S X=" Supplemental O2: "_$P(NUPAFIELDS(8),U) D SET(X)
Q
KG() Q $S(+NUPAFIELDS(3)'=9:"",1:" lb. ("_$J((+NUPAFIELDS(7)/2.2),5,1)_" kg.)")
;
K K ^TMP("NUPA",$J) Q
NONE(X) S ^TMP("NUPA",$J,1,0)=X_" - NONE FOUND" Q
NF D SET(" *** 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
;
AGO S:$D(NUPA("T"))&($G(T)="") T=NUPA("T")
N X1,X2 S X1=DT,X2=+T,X=$P(T,X2,2),X2=-X2
S X2=X2*$S(X="M":30,X="W":7,X="D":1,1:365) D C^%DTC S (NUPA("ED"),ED)=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[HNUPAOBJ1 10952 printed Apr 09, 2024@21:26:43 Page 2
NUPAOBJ1 ;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 NUPAOB package
+3 ;;IAs used: 2400, 4245, 4246, 4791, 5047
ST QUIT
+1 ;
BMI(N) ;Body Mass Index |BMI;N;nY|
+1 NEW NUPA,X
SET NUPA("T")=$PIECE(N,U,2)
SET NUPA("N")=+$GET(N,1)
+2 if NUPA("T")=""
SET NUPA("T")="2Y"
+3 DO AGO
SET NUPA("ED")=ED
SET NUPA("AGO")=9999999-NUPA("ED")
SET NUPA("C")=0
SET X="BODY MASS INDEX"
DO K
DO NONE(X)
+4 SET NUPA("BMI")=""
SET NUPA("C")=0
SET X=$$VIS(NUPA("N"),NUPA("T"),8)
+5 FOR NUPA("I")=0:0
SET NUPA("I")=$ORDER(^TMP("NUPA",$JOB,NUPA("I")))
if 'NUPA("I")
QUIT
Begin DoDot:1
+6 SET NUPA("C")=NUPA("C")+1
SET NUPA("HT",NUPA("I"))=^TMP("NUPA",$JOB,NUPA("I"),0)
End DoDot:1
+7 ;Invalid height
if NUPA("C")=1&('$PIECE($GET(NUPA("HT",1)),U,2))
SET NUPA("C")=0
+8 IF 'NUPA("C")
DO SET(X_" - NO HEIGHTS FOUND")
GOTO BMIQ
+9 SET NUPA("C")=0
SET X=$$VIS(NUPA("N"),NUPA("T"),9)
+10 FOR NUPA("I")=0:0
SET NUPA("I")=$ORDER(^TMP("NUPA",$JOB,NUPA("I")))
if 'NUPA("I")
QUIT
Begin DoDot:1
+11 SET NUPA("C")=NUPA("C")+1
SET NUPA("WT",NUPA("I"))=^TMP("NUPA",$JOB,NUPA("I"),0)
End DoDot:1
+12 ;Invalid weight
if NUPA("C")=1&('$PIECE($GET(NUPA("WT",1)),U,2))
SET NUPA("C")=0
+13 IF 'NUPA("C")
DO SET(X_" - NO WEIGHTS FOUND")
GOTO BMIQ
+14 ;D:NUPA("N")>1 SET(X)
SET NUPA("C")=0
+15 FOR NUPA("I")=1:1:NUPA("N")
if $DATA(NUPA("WT",NUPA("I")))
Begin DoDot:1
+16 SET NUPA("HT")=0
if $PIECE($GET(NUPA("HT",NUPA("I"))),U,2)
SET NUPA("HT")=$PIECE(NUPA("HT",NUPA("I")),U,2)
SET NUPA("WT")=$PIECE(NUPA("WT",NUPA("I")),U,2)
+17 ;_" "
SET NUPA("H")=NUPA("HT")*.0254
SET NUPA("H")=NUPA("H")*NUPA("H")
SET NUPA("WT")=NUPA("WT")/2.2
SET X=$$D(+NUPA("WT",NUPA("I")))
+18 if NUPA("H")
SET X=$JUSTIFY((NUPA("WT")/NUPA("H")),4,1)_" ("_X_")"
+19 if NUPA("N")=1
DO SET("BODY MASS INDEX - "_X)
if NUPA("N")>1
DO SET(" "_X)
End DoDot:1
BMIQ QUIT "~@^TMP(""NUPA"","_$JOB_")"
+1 ;
AM(N) ;Active meds, OP, IV, UD. N=number of days back
+1 NEW NUPA,X,X1,X2,Y
if $GET(N)=""
SET N=45
SET $PIECE(NUPA("SP")," ",50)=""
SET X1=DT
SET X2=-N
+2 DO C^%DTC
SET NUPA("AGO")=X
SET X1=DT
SET X2=(-N-365)
DO C^%DTC
SET NUPA("AGO",1)=X
+3 SET NUPA("C")=0
DO K
DO NONE("ACTIVE MEDS")
+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("AGO",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 ;IV/Unit Dose
IF NUPA("TYPE")[";I"
if $PIECE(^TMP("PS",$JOB,NUPA("I"),0),U,4)<NUPA("AGO")
QUIT
+10 ;Non-VA Meds
IF NUPA("TYPE")["N;O"
if $PIECE(^TMP("PS",$JOB,NUPA("I"),0),U,9)'="ACTIVE"
QUIT
+11 ;OP RX Last Dispense date + Days supply not in range
IF NUPA("TYPE")["R;O"
SET X1=$PIECE(^TMP("PS",$JOB,NUPA("I"),0),U,10)
SET X2=$PIECE(^TMP("PS",$JOB,NUPA("I"),0),U,11)
DO C^%DTC
if X<NUPA("AGO")
QUIT
+12 SET NUPA("C")=NUPA("C")+1
+13 SET X=$SELECT(NUPA("TYPE")["N;O":"N",NUPA("TYPE")["R;O":"O",NUPA("TYPE")["U;I":"U",NUPA("TYPE")["V;I":"V",1:"UNK")
+14 SET ^TMP("NUPA",$JOB,"SORT",X,$PIECE(^TMP("PS",$JOB,NUPA("I"),0),U,2),NUPA("C"))=$PIECE(^TMP("PS",$JOB,NUPA("I"),0),U,10,11)_U_$PIECE(^TMP("PS",$JOB,NUPA("I"),0),U,4)_U_NUPA("TYPE")
End DoDot:1
+15 SET NUPA("C")=0
+16 FOR NUPA("SUB")="O","V","U"
Begin DoDot:1
+17 DO SET("*** "_$SELECT(NUPA("SUB")="O":"Outpatient",NUPA("SUB")="V":"IV",1:"Unit Dose")_" ***")
+18 if '$DATA(^TMP("NUPA",$JOB,"SORT",NUPA("SUB")))
DO NF
SET NUPA("RX")=""
+19 FOR
SET NUPA("RX")=$ORDER(^TMP("NUPA",$JOB,"SORT",NUPA("SUB"),NUPA("RX")))
if NUPA("RX")=""
QUIT
Begin DoDot:2
+20 FOR NUPA("I")=0:0
SET NUPA("I")=$ORDER(^TMP("NUPA",$JOB,"SORT",NUPA("SUB"),NUPA("RX"),NUPA("I")))
if 'NUPA("I")
QUIT
Begin DoDot:3
+21 SET X=" Drug: "_($EXTRACT(NUPA("RX")_NUPA("SP"),1,45))
+22 if NUPA("SUB")="O"
SET X=X_" Last Dispensed: "_$$D($PIECE(^TMP("NUPA",$JOB,"SORT",NUPA("SUB"),NUPA("RX"),NUPA("I")),U))_" ("_$PIECE(^TMP("NUPA",$JOB,"SORT",NUPA("SUB"),NUPA("RX"),NUPA("I")),U,2)_" days)"
+23 if NUPA("SUB")'="O"
SET X=X_" Stop Date: "_$$D($PIECE(^TMP("NUPA",$JOB,"SORT",NUPA("SUB"),NUPA("RX"),NUPA("I")),U,3))
+24 DO SET(X)
End DoDot:3
End DoDot:2
End DoDot:1
+25 KILL ^TMP("NUPA",$JOB,"SORT"),^TMP("PS",$JOB)
+26 QUIT "~@^TMP(""NUPA"","_$JOB_")"
+27 ;
ONE(X) ;Single lab test in a time period object.
+1 ;X should be "Data name^# of occurances^time period (nM, nD, or nY)"
+2 ;or X could be "Print string^# of occurances^time period (nM, nD, or nY)^Data name number^Print completed time"
+3 NEW NUPA
SET NUPA("TN")=X
SET C=0
SET $PIECE(NUPA("SP")," ",50)=""
+4 SET NUPA("N")=$PIECE(NUPA("TN"),U,2)
SET NUPA("T")=$PIECE(NUPA("TN"),U,3)
+5 if 'NUPA("N")
SET NUPA("N")=99
if NUPA("T")=""
SET NUPA("T")="99Y"
+6 if '$PIECE(NUPA("TN"),U,4)
SET NUPA("TEST")=$ORDER(^DD(63.04,"B",$PIECE(NUPA("TN"),U),0))
+7 if $PIECE(NUPA("TN"),U,4)
SET NUPA("TEST")=$PIECE(NUPA("TN"),U,4)
+8 IF 'NUPA("TEST")
Begin DoDot:1
+9 DO K
SET ^TMP("NUPA",$JOB,1,0)=$PIECE(NUPA("TN"),U)_" - INVALID TEST NAME"
End DoDot:1
QUIT "~@^TMP(""NUPA"","_$JOB_")"
+10 FOR NUPA("I")=1:1:NUPA("N")
SET NUPA("TEST",NUPA("I"))=0
SET NUPA("TEST",NUPA("I"),NUPA("TEST"))=""
+11 ;IA 4246
SET X=$$TEST^LRPXAPIU(NUPA("TEST"))
SET NUPA("VALIDTESTS",X)=NUPA("TEST")
SET NUPA("VALIDTESTS","B",NUPA("TEST"))=X
+12 SET (NUPA("CHK",1),NUPA("CHK",2))=NUPA("TEST")
DO GET
+13 IF NUPA("TEST",1)
SET X=$EXTRACT($PIECE(NUPA("TN"),U)_NUPA("SP"),1,26)_" "
Begin DoDot:1
+14 IF 'NUPA("TEST",1)
SET X=X_" NO DATA ON FILE"
DO SET(X)
QUIT
+15 FOR NUPA("I")=1:1:NUPA("N")-1
if NUPA("TEST",NUPA("I"))
Begin DoDot:2
+16 SET X=$SELECT(NUPA("I")=1:X,1:$EXTRACT(NUPA("SP"),1,27))_$$D1(NUPA("TEST",NUPA("I")))_NUPA("SP")
+17 SET X=$EXTRACT(X,1,45)_$PIECE(NUPA("TEST",NUPA("I"),NUPA("CHK",1)),U)_" "_$PIECE(NUPA("TEST",NUPA("I"),NUPA("CHK",1)),U,2)
+18 if $PIECE(NUPA("TN"),U,5)
SET X=$EXTRACT(X_NUPA("SP"),1,55)_$$CONV2($PIECE(NUPA("TEST",NUPA("I")),U,2))
+19 DO SET(X)
End DoDot:2
End DoDot:1
+20 ;also display Verify Date
if $PIECE(NUPA("TN"),U,5)
Begin DoDot:1
+21 FOR NUPA("I")=9E9:0
SET NUPA("I")=$ORDER(^TMP("NUPA",$JOB,NUPA("I")),-1)
if 'NUPA("I")
QUIT
Begin DoDot:2
+22 SET ^TMP("NUPA",$JOB,NUPA("I")+2,0)=^TMP("NUPA",$JOB,NUPA("I"),0)
End DoDot:2
+23 SET ^TMP("NUPA",$JOB,1,0)=" TEST COLLECTION DATE RESULT VERIFY DATE"
+24 SET ^TMP("NUPA",$JOB,2,0)=""
End DoDot:1
ONEQ QUIT "~@^TMP(""NUPA"","_$JOB_")"
+1 ;
GET ;Get data from ^LR(DFN,"CH")
+1 NEW NUPATEST,ED,LRDFN,T,X
SET T=NUPA("T")
DO K
DO NONE($PIECE(NUPA("TN"),U))
DO AGO
SET NUPA("ED")=ED
+2 SET NUPA("N")=1
SET LRDFN=$$GETL()
if 'LRDFN
QUIT
+3 ;IA 4245
DO RESULTS^LRPXAPI(.NUPATEST,DFN,"C",999,"","",DT,NUPA("ED"))
+4 FOR NUPA("I")=0:0
SET NUPA("I")=$ORDER(NUPA("VALIDTESTS",NUPA("I")))
if 'NUPA("I")
QUIT
Begin DoDot:1
+5 SET NUPA("VALIDTESTS","B",NUPA("VALIDTESTS",NUPA("I")))=NUPA("I")
End DoDot:1
+6 SET X=""
FOR
SET X=$ORDER(NUPATEST(X))
if X=""
QUIT
Begin DoDot:1
+7 if '$PIECE(NUPATEST(X),U,2)
QUIT
if '$DATA(NUPA("VALIDTESTS",$PIECE(NUPATEST(X),U,2)))
QUIT
+8 SET ^TMP("NUPA",$JOB,"SORT",-NUPATEST(X),$PIECE(NUPATEST(X),U,2))=$PIECE(NUPATEST(X),U,4,5)
End DoDot:1
+9 FOR NUPA("I")=-9E9:0
SET NUPA("I")=$ORDER(^TMP("NUPA",$JOB,"SORT",NUPA("I")))
if 'NUPA("I")
QUIT
Begin DoDot:1
+10 SET NUPA("FLAG")=0
+11 FOR NUPA("II")=0:0
SET NUPA("II")=$ORDER(^TMP("NUPA",$JOB,"SORT",NUPA("I"),NUPA("II")))
if 'NUPA("II")
QUIT
Begin DoDot:2
+12 if '$DATA(^TMP("NUPA",$JOB,"SORT",NUPA("I"),NUPA("VALIDTESTS","B",NUPA("CHK",1))))!('$DATA(^TMP("NUPA",$JOB,"SORT",NUPA("I"),NUPA("VALIDTESTS","B",NUPA("CHK",2)))))
QUIT
+13 SET NUPA("TEST")=NUPA("VALIDTESTS",NUPA("II"))
if '$DATA(NUPA("TEST",NUPA("N"),NUPA("TEST")))
QUIT
+14 if 'NUPA("TEST",NUPA("N"),NUPA("TEST"))
SET NUPA("TEST",NUPA("N"),NUPA("TEST"))=^TMP("NUPA",$JOB,"SORT",NUPA("I"),NUPA("II"))
SET NUPA("FLAG")=1
End DoDot:2
+15 if NUPA("FLAG")
SET NUPA("TEST",NUPA("N"))=-NUPA("I")
SET NUPA("N")=NUPA("N")+1
End DoDot:1
+16 KILL ^TMP("NUPA",$JOB,"SORT")
QUIT
+17 ;
GETL() ;Get LRDFN
+1 ;IA 4246
SET DFN=+$GET(DFN)
QUIT $$LRDFN^LRPXAPIU(DFN)
+2 ;
CONV() ;IA 4246
QUIT $$CONV2($$LRIDT^LRPXAPIU(NUPA("TEST",NUPA("I"))))
CONV2(X) NEW XX
SET XX=$EXTRACT($PIECE(X,".",2)_"0000",1,4)
+1 SET X=X_$EXTRACT(XX,1,2)_":"_$EXTRACT(XX,3,4)
+2 SET X=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)_" @ "
+3 SET X=X_$EXTRACT(XX,1,2)_":"_$EXTRACT(XX,3,4)
QUIT X
+4 ;
VIS(NUPAHOWMANY,NUPABACK,NUPATYPE,NUPAQUALIFERS) ;
+1 ;NUPAHOWMANY Should be set to how many results you want back
+2 ;NUPABACK should contain the starting date to go back to
+3 ;NUPATYPE Is the vital ien that you want to report on this is in file (#120.51) NOTE THIS CAN LOOK LIKE "1;2;8;22"
+4 ;NUPAQUALIFERS Set this to 1 if you want to see the Qualifiers in the output
+5 ; 0: Date, description, value, no qualifiers
+6 ; 1: Date, description, value, qualifiers
+7 ; 2: Value, date, qualifiers, no description
+8 ; 3: Description, value, date, no qualifiers
+9 ; 4: Description, value, date, qualifiers
+10 ;You must have the users DFN in your table before calling the VIS tag.
+11 NEW C,ED,I,II,X,X1,X2,NUPACNT,NUPAREVDT,NUPAIEN,NUPAFIELDS,NUPAPIECE1,NUPAPIECE2,NUPASPACE,NUPATEMP,NUPAZZ,GMRVSTR
+12 SET (C,NUPACNT)=0
+13 KILL ^UTILITY($JOB,"GMRVD")
+14 ;------------------------------------
+15 SET NUPAALL=NUPATYPE
FOR NUPALOOP=1:1
SET NUPATYPE=$PIECE(NUPAALL,";",NUPALOOP)
if NUPATYPE=""
QUIT
DO V2
+16 ;-------------------------------------
+17 SET X=$$FIELD^GMVGETVT(NUPATYPE,1,"E")
+18 ;IA 5047
IF $DATA(^UTILITY($JOB,"GMRVD"))=0
SET X="No "_$SELECT(X=-1:"",1:X)_"vitals found."
DO SET(X)
+19 KILL NUPACNT,NUPAREVDT,NUPAIEN,NUPAFIELDS,NUPAPIECE1,NUPAPIECE2,NUPASPACE,NUPATEMP,NUPAZZ
+20 KILL NUPAHOWMANY,NUPABACK,NUPATYPE,NUPAQUALIFERS,NUPAALL,NUPALOOP
+21 KILL ^UTILITY($JOB,"GMRVD")
+22 QUIT "~@^TMP(""NUPA"","_$JOB_")"
+23 ;-------------------------------------
V2 ;
+1 KILL NUPAVITNAM,T,ED,NUPAFIELDS,NUPATEMP,NUPAZZ,X
+2 DO K
KILL ^UTILITY($JOB,"GMRVD")
+3 ;IA 5047
SET NUPAVITNAM=$$FIELD^GMVGETVT(NUPATYPE,2,"I")
+4 IF $GET(NUPAVITNAM)=""
SET X="No Vital type on file"
DO SET(X)
QUIT
+5 SET T=NUPABACK
DO AGO
+6 SET GMRVSTR=NUPAVITNAM
SET GMRVSTR(0)=ED_"^"_(DT+.9999)_"^"_NUPAHOWMANY_"^"_1
+7 ;IA 4791
DO EN1^GMVHS
+8 SET NUPAREVDT=""
FOR
SET NUPAREVDT=$ORDER(^UTILITY($JOB,"GMRVD",NUPAREVDT))
if (NUPAREVDT="")!('+NUPAREVDT)
QUIT
Begin DoDot:1
+9 SET NUPACNT=NUPACNT+1
+10 SET NUPAIEN=0
FOR
SET NUPAIEN=$ORDER(^UTILITY($JOB,"GMRVD",NUPAREVDT,NUPAVITNAM,NUPAIEN))
if (NUPAIEN="")!('+NUPAIEN)
QUIT
DO BUILD
End DoDot:1
+11 QUIT
BUILD ;
+1 KILL NUPAFIELDS
+2 SET NUPAFIELDS(.01)="2"
+3 SET NUPAFIELDS(5)=5
+4 DO EN^GMVPXRM(.NUPAFIELDS,NUPAIEN,"B")
+5 ;$$FMTE^XLFDT($P($G(NUPAFIELDS(1)),U,1),"5"))
SET NUPAPIECE1=$SELECT($DATA(NUPA("BMI")):+$GET(NUPAFIELDS(1)),1:$PIECE($GET(NUPAFIELDS(1)),U,2))
+6 SET NUPAPIECE2=$SELECT($DATA(NUPA("BMI")):"",1:$PIECE($GET(NUPAFIELDS(3)),U,2)_": ")_$PIECE($GET(NUPAFIELDS(7)),U,2)
+7 SET NUPASPACE=$JUSTIFY("",35-$LENGTH(NUPAPIECE1))
+8 IF $GET(NUPASORT)="VIT"
SET ^TMP("NUPA",$JOB,"PRE",NUPAREVDT,NUPAPIECE1,NUPATYPE,0)=$PIECE($GET(NUPAPIECE2),":",2)
QUIT
+9 IF $GET(NUPASORT)="PVI"
SET ^TMP("NUPA",$JOB,"PRE",NUPAREVDT,NUPAPIECE1,NUPATYPE,0)=$PIECE($GET(NUPAPIECE2),":",2)
QUIT
+10 if $GET(NUPAQUALIFERS)<2
Begin DoDot:1
+11 if $DATA(NUPA("BMI"))
SET X=NUPAPIECE1_U_NUPAPIECE2
+12 if '$DATA(NUPA("BMI"))
SET X=$EXTRACT(NUPAPIECE1_NUPASPACE,1,24)_NUPAPIECE2_$$KG()
DO SET(X)
End DoDot:1
+13 IF $GET(NUPAQUALIFERS)=2
SET X=$EXTRACT($PIECE(NUPAPIECE2,": ",2)_$$KG()_NUPASPACE,1,24)_NUPAPIECE1
DO SET(X)
+14 IF $GET(NUPAQUALIFERS)=3!($GET(NUPAQUALIFERS)=4)
SET X=$EXTRACT(NUPAPIECE2_$$KG()_NUPASPACE,1,24)_NUPAPIECE1
DO SET(X)
+15 SET NUPATEMP=""
KILL X
+16 SET NUPAZZ=0
FOR
SET NUPAZZ=$ORDER(NUPAFIELDS(12,NUPAZZ))
if (NUPAZZ="")!('+NUPAZZ)
QUIT
Begin DoDot:1
+17 if $GET(NUPAFIELDS(12,NUPAZZ))="^"
QUIT
+18 IF NUPAZZ>1
SET NUPATEMP=NUPATEMP_", "
+19 SET NUPATEMP=NUPATEMP_$PIECE($GET(NUPAFIELDS(12,NUPAZZ)),U,2)
End DoDot:1
+20 if '$GET(NUPAQUALIFERS)!($GET(NUPAQUALIFERS)=3)
QUIT
+21 ;I $G(NUPAQUALIFERS)=1,$L(NUPATEMP)>1
+22 SET X=" Qualifier"_$SELECT(NUPATEMP[",":"s: ",1:": ")_NUPATEMP
DO SET(X)
+23 IF NUPAFIELDS(3)["PULSE OX"
SET X=" Supplemental O2: "_$PIECE(NUPAFIELDS(8),U)
DO SET(X)
+24 QUIT
KG() QUIT $SELECT(+NUPAFIELDS(3)'=9:"",1:" lb. ("_$JUSTIFY((+NUPAFIELDS(7)/2.2),5,1)_" kg.)")
+1 ;
K KILL ^TMP("NUPA",$JOB)
QUIT
NONE(X) SET ^TMP("NUPA",$JOB,1,0)=X_" - NONE FOUND"
QUIT
NF DO SET(" *** 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
+1 ;
AGO if $DATA(NUPA("T"))&($GET(T)="")
SET T=NUPA("T")
+1 NEW X1,X2
SET X1=DT
SET X2=+T
SET X=$PIECE(T,X2,2)
SET X2=-X2
+2 SET X2=X2*$SELECT(X="M":30,X="W":7,X="D":1,1:365)
DO C^%DTC
SET (NUPA("ED"),ED)=X
QUIT
+3 ;
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)
