NUPABCL2 ;PHOENIX/KLD; 2/23/09; ADMISSION ASSESSMENT/CAREPLAN BROKER CALLS; 1/13/12 3:55 PM
;;1.0;NUPA;;;Build 105
ST Q
;
APO(R,DFN) ;Active/pending orders.
N A,C,HR24,I,II,ORD,X,X1,X2,YEST K ^TMP($J)
S HR24=$P(DFN,U,2),DFN=+DFN,A=DFN_";DPT(",C=0
S YEST="" I HR24 S X1=DT,X2=-1 D C^%DTC S YEST=9999999-X
F I=0:0 S I=$O(^OR(100,"AC",A,I)) Q:'HR24&('I) Q:HR24&(I>YEST) Q:'I D
.F ORD=1:0 S ORD=$O(^OR(100,"AC",A,I,ORD)) Q:'ORD D
..S X=$$GET1^DIQ(100,ORD,1),X("PROV")=$S(X]"":X,1:"UNKNOWN")
..S X=$$GET1^DIQ(100,ORD,21),X("SD")=$S(X]"":X,1:"UNKNOWN")
..S X=$$GET1^DIQ(100,ORD,5) Q:X'="ACTIVE"&(X'="PENDING") ;Get only Active & Pending orders
..S X=$$GET1^DIQ(100,ORD,2) Q:X["ALLERGY ENTER/EDIT"
..;next IF is for text orders with no orderable items
..;IA 3800 allows direct global reads of ^OR(100,D0,.1
..D:'$D(^OR(100,ORD,.1)) TEXTORD
..F II=0:0 S II=$O(^OR(100,ORD,.1,II)) Q:'II D
...S X(101.43)=$G(^ORD(101.43,+^OR(100,ORD,.1,II,0),0)),X=$P(X(101.43),U,5)
...S X("DG")=$S(X:$P(^ORD(100.98,X,0),U),1:"UNKNOWN") ;Display group
...S X("ITEM")=$P(X(101.43),U) D SET
S:'$D(^TMP($J)) ^TMP($J,0)="NONE FOUND" S R=$NA(^TMP($J)) Q
TEXTORD N I,II,III,TO S X("DG")="Text Order",X("ITEM")=""
F I=0:0 S I=$O(^OR(100,ORD,8,I)) Q:'I D
.F II=0:0 S II=$O(^OR(100,ORD,8,I,.1,II)) Q:'II D
..S X("ITEM")=X("ITEM")_" "_^OR(100,ORD,8,I,.1,II,0)
D:X("ITEM")]"" SET Q
;
IM(R,DFN) ;Inpatient med list
N DAYS,FLAG S DAYS=$P(DFN,U,2),DFN=+DFN,FLAG=0 D AM^NUPAOBJ1(DAYS)
K ^TMP($J) F I=0:0 S I=$O(^TMP("NUPA",$J,I)) Q:'I D
.S:^TMP("NUPA",$J,I,0)["IV Meds" FLAG=1 S:FLAG ^TMP($J,I)=^TMP("NUPA",$J,I,0)
K ^TMP("NUPA",$J) S R=$NA(^TMP($J)) Q
;
CPH(R,DA) ;History of the whole care plan
K ^TMP($J) N C,I,II,REC,X S C=0 S REC=$G(^NUPA(1927.4,DA,0))
D SET1("Plan entered on "_$$D($P(REC,U)))
D SET1("By: "_$S($P(REC,U,3):$$GET1^DIQ(200,$P(REC,U,3),.01),1:"UNKNOWN"))
I '$D(^NUPA(1927.5,"B",DA)) D SET1(""),SET1("No changes for this plan of care")
F I=9E9:0 S I=$O(^NUPA(1927.5,"B",DA,I),-1) Q:'I D
.S X=$G(^NUPA(1927.5,I,0)) D SET1("")
.D SET1("Field "_$S($P(X,U,2):$P(^DD(1927.4,$P(X,U,2),0),U),1:"Unknown")_" was changed on")
.D SET1($$D($P(X,U,3))_" by "_$S($P(X,U,4):$$GET1^DIQ(200,$P(X,U,4),.01),1:"UNKNOWN"))
.S X=" Old value: " S:$P($G(^NUPA(1927.5,I,1,0)),U,3)=1 X=X_^NUPA(1927.5,I,1,1,0)
.D SET1(X) D:$P($G(^NUPA(1927.5,I,1,0)),U,3)>1
..F II=0:0 S II=$O(^NUPA(1927.5,I,1,II)) Q:'II D SET1(" "_^NUPA(1927.5,I,1,II,0))
.S X=" New value: " S:$P($G(^NUPA(1927.5,I,2,0)),U,3)=1 X=X_^NUPA(1927.5,I,2,1,0)
.D SET1(X) D:$P($G(^NUPA(1927.5,I,2,0)),U,3)>1
..F II=0:0 S II=$O(^NUPA(1927.5,I,2,II)) Q:'II D SET1(" "_^NUPA(1927.5,I,2,II,0))
S R=$NA(^TMP($J)) Q
;
DPH(R,DA,FLAG) ;Discharge planning comments
;FLAG=1: All comments. FLAG=2: Latest comment.
N CNT,I,II,PROB K ^TMP($J) S CNT=1,^TMP($J,"LIST",1)="*** Prior comments ***"
S ^TMP($J,"LIST",2)=" NONE"
F I=9E9:0 S I=$O(^NUPA(1927.6,"B",DA,I),-1) Q:'I D
.S PROB=$P($G(^NUPA(1927.6,I,0)),U,2),PROB("D")=$P(^NUPA(1927.6,I,0),U,4) Q:'PROB
.I FLAG=1 D DPHS(I) Q
.Q:$D(^TMP($J,"SORT",PROB)) S ^TMP($J,"SORT",PROB)=I
I FLAG=2 F PROB=0:0 S PROB=$O(^TMP($J,"SORT",PROB)) Q:'PROB D DPHS(^TMP($J,"SORT",PROB))
K ^TMP($J,"SORT") S R=$NA(^TMP($J,"LIST")) Q
DPHS(N) N II S CNT=CNT+1,^TMP($J,"LIST",CNT)="Discharge planning issue: "_$P($$GET1^DIQ(1927.41,PROB,.01),"*")
F II=0:0 S II=$O(^NUPA(1927.6,N,1,II)) Q:'II D
.S CNT=CNT+1,^TMP($J,"LIST",CNT)=^NUPA(1927.6,N,1,II,0)
S CNT=CNT+1,^TMP($J,"LIST",CNT)="Comment added by "_$$GET1^DIQ(200,$P($G(^NUPA(1927.6,N,0)),U,3),.01)_" ("_$$GET1^DIQ(200,$P($G(^NUPA(1927.6,N,0)),U,3),8)_") on "_$$D1(PROB("D"))
S CNT=CNT+1,^TMP($J,"LIST",CNT)="" Q
;
UL(R,DA) ;List of pressure ulcers & other skin alterations for this care plan
N C,NUPA,X S C=0 K ^TMP($J)
F NUPA("I")=0:0 S NUPA("I")=$O(^NUPA(1927.401,"B",DA,NUPA("I"))) Q:'NUPA("I") S X=NUPA("I") D
.Q:$$GET1^DIQ(1927.401,NUPA("I"),1)="" ;No location
.F NUPA("II")=1:1:7 S:NUPA("II")'=4 X=X_U_$$GET1^DIQ(1927.401,NUPA("I"),NUPA("II"))
.D SET1(X)
S R=$NA(^TMP($J)) Q
;
SL(R,NUPADAT) ;Set pressure ulcers & other skin alterations for this care plan
;X(n)="A" or "P" ^ Care plan DA ^ Data 1 ^ Data 2 ^ Data 3 ^ # of lines of comments ^ Comments ^ Healed (1 or 0)
N DA,DIC,DIE,DR,NUPA,NUPAALTS S (DIC,DIE)="^NUPA(1927.401,",DIC(0)="L"
F NUPA("I")=-1:0 S NUPA("I")=$O(NUPADAT(NUPA("I"))) Q:NUPA("I")="" D
.S DA=-1
.F NUPA("II")=0:0 S NUPA("II")=$O(^NUPA(1927.401,"B",$P(NUPADAT(NUPA("I")),U,2),NUPA("II"))) Q:'NUPA("II")!(DA>0) D
..S:$P(NUPADAT(NUPA("I")),U)="A"&($$GET1^DIQ(1927.401,NUPA("II"),5)=$P(NUPADAT(NUPA("I")),U,3))&($$GET1^DIQ(1927.401,NUPA("II"),1)=$P(NUPADAT(NUPA("I")),U,4)) DA=NUPA("II") ;Type, Location check
..S:$P(NUPADAT(NUPA("I")),U)="P"&($$GET1^DIQ(1927.401,NUPA("II"),5)="Pressure Ulcer")&($$GET1^DIQ(1927.401,NUPA("II"),1)=$P(NUPADAT(NUPA("I")),U,3)) DA=NUPA("II")
.S DR=""
.I DA=-1 K DD,DO S X=$P(NUPADAT(NUPA("I")),U,2) D FILE^DICN S DA=+Y S:$P(NUPADAT(NUPA("I")),U)="P" DR="5///Pressure Ulcer;"
.S DR=DR_"1///"_$P(NUPADAT(NUPA("I")),U,$S($P(NUPADAT(NUPA("I")),U)="A":4,1:3))
.I $P(NUPADAT(NUPA("I")),U)="A" D
..S DR=DR_";5///"_$P(NUPADAT(NUPA("I")),U,3)_";6///"_$P(NUPADAT(NUPA("I")),U,5)
..S:$P(NUPADAT(NUPA("I")),U,8) DR=DR_";7///1" ;Healed
.S:$P(NUPADAT(NUPA("I")),U)="P" DR=DR_";2///"_$P(NUPADAT(NUPA("I")),U,4)_";3///"_$P(NUPADAT(NUPA("I")),U,5)
.D ^DIE
.F NUPA("III")=1:1:$P(NUPADAT(NUPA("I")),U,6) D ;Comments
..D WPSET^NUPABCL(.R,"^NUPA(1927.401,"_DA_",1",NUPA("III"),$P($P(NUPADAT(NUPA("I")),U,7),"***",NUPA("III")))
S R=1 Q
;
IV(R,DA) ;List of IVs for this care plan
N C,I,II,NUPADC S C=0,NUPADC=$P(DA,U,2),DA=+DA K ^TMP($J)
F I=0:0 S I=$O(^NUPA(1927.402,"B",DA,I)) Q:'I S X=I D
.Q:$$GET1^DIQ(1927.402,I,1)="" ;No location
.;I 'NUPADC Q:$$GET1^DIQ(1927.402,I,6)]"" ;D/Ced IVs
.F II=1:1:8,10:1:13 S X=X_U_$$GET1^DIQ(1927.402,I,II)
.D SET1(X)
S R=$NA(^TMP($J)) Q
;
GC(R) ;Get component information
K ^TMP($J) N CNT,I,II,X S CNT=0
F I=0:0 S I=$O(^NUPA(1927.41,I)) Q:'I D
.F II=0:0 S II=$O(^NUPA(1927.41,I,1,II)) Q:'II S X=^NUPA(1927.41,I,1,II,0) D:$P(X,U,3)
..S CNT=CNT+1,^TMP($J,CNT)=^NUPA(1927.41,I,0)_U_I_U_$P(X,U,1,2)
S R=$NA(^TMP($J)) Q
;
GI(R,DA) ;List of GI/GU devices for this care plan
N C,I,II,X S C=0 K ^TMP($J)
F I=0:0 S I=$O(^NUPA(1927.403,"B",DA,I)) Q:'I S X=I D
.Q:$P(^NUPA(1927.403,I,0),U,4) ;Removed
.F II=1,2,3,5 S X=X_U_$$GET1^DIQ(1927.403,I,II)
.D SET1(X)
S R=$NA(^TMP($J)) Q
;
RAOK(R,DFN) ;Check if it's OK to show the update reassessment radiobuttons
;Must be at least one reassessment note since admission
;Note must be in last 24 hours
N %DT,ADM,DA,H1,H2,NUPANOTX,NUPATIME,RANOTE,X,Y
S ADM=$P($$LADM^NUPAOBJ(2),U) I ADM=0 S R="0^NOT ADMITTED" Q
S NUPANOTX="",RANOTE=$$LN^NUPAOBJ("RN REASSESSMENT","1D")
S RANOTE=$G(^TMP("NUPA",$J,1,0))
I RANOTE["#0" S R="0^None in last 24 hours" Q ;None found
S DA=$P($P(RANOTE,"#",2),")"),NUPATIME=$$GET1^DIQ(8925,DA,1201)
S RANOTE=$P($P(RANOTE,": ",2)," ("),RANOTE=$P(RANOTE,":",1,2)
S %DT="R",X=RANOTE D ^%DT
S H1=$$FMTH^XLFDT(Y),X=$$HDIFF^XLFDT($H,H1,3)
S R=$S($E(X):0,+$P(X," ",2)>23:0,1:1)_U_NUPATIME Q
;
HF(R) ;Get ONS Health Factors
N C,DIC,NUPA,X,Y S C=0 K ^TMP($J),^TMP("DILIST",$J)
D FIND^DIC(9999999.64,"",.01,"P","ONS",9999)
F NUPA("I")=0:0 S NUPA("I")=$O(^TMP("DILIST",$J,NUPA("I"))) Q:'NUPA("I") D
.S X=^TMP("DILIST",$J,NUPA("I"),0)
.D:X["ONS AA"!(X["ONS RA")!(X["ONS TOBACCO") SET1($P(X,U,2)_U_$P(X,U))
;S DIC="^AUTTHF(",DIC(0)="M"
;S X="LIFETIME NON-USER OF TOBACCO" D ^DIC D SET1($P(Y,U,2)_U_+Y)
;S X="FORMER TOBACCO USER" D ^DIC D SET1($P(Y,U,2)_U_+Y)
;S X="CURRENT TOBACCO USER" D ^DIC D SET1($P(Y,U,2)_U_+Y)
K ^TMP($J,"SORT") S R=$NA(^TMP($J)) Q
;
ALG(R,DFN) ;Get allergies
N NUPA,GMRAL S NUPA("CNT")=0
D EN1^GMRADPT ;IA 10099
F NUPA("I")=0:0 S NUPA("I")=$O(GMRAL(NUPA("I"))) Q:'NUPA("I") D
.S NUPA("CNT")=NUPA("CNT")+1,R(NUPA("CNT"))=$P(GMRAL(NUPA("I")),U,2)_U_NUPA("I")
Q
APPTS(R,DFN) ;Get future appointments
N NUPA,X,X1,X2 S $P(NUPA("SP")," ",20)="",X1=DT,X2=365 D C^%DTC
S NUPA(1)=DT_";"_X,NUPA(4)=DFN,NUPA("FLDS")="2;3;9",NUPA("SORT")="P"
S NUPA("CNT")=0,CNT=$$SDAPI^SDAMA301(.NUPA) ;IA 4433
;S ^TMP("NUPA",$J,1)="DATE CLINIC",^TMP("NUPA",$J,2)=""
F NUPA("I")=0:0 S NUPA("I")=$O(^TMP($J,"SDAMA301",DFN,NUPA("I"))) Q:'NUPA("I") D
.Q:$P($P(^TMP($J,"SDAMA301",DFN,NUPA("I")),U,3),";")["C" ;Cancelled
.S NUPA("CNT")=NUPA("CNT")+1,^TMP("NUPA",$J,NUPA("CNT"))=$E($$D(NUPA("I"))_NUPA("SP"),1,20)_$P($P(^TMP($J,"SDAMA301",DFN,NUPA("I")),U,2),";",2)
S:NUPA("CNT")=0 ^TMP("NUPA",$J,1)="NONE"
S R=$NA(^TMP("NUPA",$J)) Q
;
ACNOTE(R,DFN,NUPASTR) ;Create Audit C note text based on last administration
N NUPA,NUPATEXT,X S NUPA("VIS")="",NUPA("NEVER")=0
S NUPA("DA")=$O(^YTT(601.84,"C",DFN,9E9),-1)
I 'NUPA("DA") S R(1)="No instrument administration on file" Q
S NUPA("LOC")=$$GET1^DIQ(601.84,NUPA("DA"),13,"I")
S NUPATEXT(1)="Alcohol Use Disorders Identification Test Consumption (AUDC)"
S NUPATEXT(2)=""
S NUPATEXT(3)="Date Given: "_$P($$GET1^DIQ(601.84,NUPA("DA"),3),"@")
S NUPATEXT(4)="Clinician: "_$$GET1^DIQ(601.84,NUPA("DA"),6)
S NUPATEXT(5)="Location: "_NUPA("LOC")
S NUPATEXT(6)=""
S NUPATEXT(7)="Veteran: "_$$GET1^DIQ(601.84,NUPA("DA"),1)
S NUPATEXT(8)="SSN: "_"xxx-xx-"_$E($$GET1^DIQ(2,DFN,.09),6,9)
S NUPATEXT(9)="DOB: "_$$GET1^DIQ(2,DFN,.03)_" ("_$$GET1^DIQ(2,DFN,.033)_")"
S NUPATEXT(10)="Gender: "_$$GET1^DIQ(2,DFN,.02)
S NUPATEXT(11)=""
S NUPATEXT(12)=""
S NUPATEXT(13)=" AUDC Score: "_$P($P(NUPASTR,U,4),"~",2)_" points"
S NUPATEXT(14)=""
S NUPATEXT(15)="In men, a score of 4 or more is considered positive; in women, a score of 3 or "
S NUPATEXT(16)="more is considered positive."
S NUPATEXT(17)=""
S NUPATEXT(18)=" Questions and Answers"
S NUPATEXT(19)="",NUPA("CNT")=19,NUPASTR=$P(NUPASTR,U,5)
F NUPA("I")=2:1 Q:$P(NUPASTR,"*",NUPA("I"))="" D
.S:NUPA("I")=2&($P($P(NUPASTR,"*",NUPA("I")),"~",2)["Never") NUPA("NEVER")=1
.S NUPA("CNT")=NUPA("CNT")+1,NUPATEXT(NUPA("CNT"))=$P($P(NUPASTR,"*",NUPA("I")),"~")
.S NUPA("CNT")=NUPA("CNT")+1,NUPATEXT(NUPA("CNT"))=" "_$P($P(NUPASTR,"*",NUPA("I")),"~",2)
.S:NUPA("I")>2&(NUPA("NEVER")) NUPATEXT(NUPA("CNT"))=" Not asked (patient reports no drinking in past year)"
S NUPA("CNT")=NUPA("CNT")+1,NUPATEXT(NUPA("CNT"))=""
S NUPA("CNT")=NUPA("CNT")+1,NUPATEXT(NUPA("CNT"))="Information contained in this note is based on a self report assessment and is"
S NUPA("CNT")=NUPA("CNT")+1,NUPATEXT(NUPA("CNT"))="not sufficient to use alone for diagnostic purposes. Assessment results should"
S NUPA("CNT")=NUPA("CNT")+1,NUPATEXT(NUPA("CNT"))="be verified for accuracy and used in conjunction with other diagnostic activities."
M R=NUPATEXT Q
NOTENM() Q "1781^MENTAL HEALTH DIAGNOSTIC STUDY NOTE" ;IEN & name of Note Title
;
SET S C=C+1,^TMP($J,X("DG"),X("SD"),ORD,C)=X("DG")_U_X("ITEM")_U_X("SD")_U_X("PROV") Q
SET1(X) S C=C+1,^TMP($J,C)=X Q
D(Y) D DD^%DT Q Y
D1(Y) D DD^%DT Q $P(Y,"@")_" on "_$P(Y,"@",2)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNUPABCL2 11216 printed Sep 23, 2025@19:59:50 Page 2
NUPABCL2 ;PHOENIX/KLD; 2/23/09; ADMISSION ASSESSMENT/CAREPLAN BROKER CALLS; 1/13/12 3:55 PM
+1 ;;1.0;NUPA;;;Build 105
ST QUIT
+1 ;
APO(R,DFN) ;Active/pending orders.
+1 NEW A,C,HR24,I,II,ORD,X,X1,X2,YEST
KILL ^TMP($JOB)
+2 SET HR24=$PIECE(DFN,U,2)
SET DFN=+DFN
SET A=DFN_";DPT("
SET C=0
+3 SET YEST=""
IF HR24
SET X1=DT
SET X2=-1
DO C^%DTC
SET YEST=9999999-X
+4 FOR I=0:0
SET I=$ORDER(^OR(100,"AC",A,I))
if 'HR24&('I)
QUIT
if HR24&(I>YEST)
QUIT
if 'I
QUIT
Begin DoDot:1
+5 FOR ORD=1:0
SET ORD=$ORDER(^OR(100,"AC",A,I,ORD))
if 'ORD
QUIT
Begin DoDot:2
+6 SET X=$$GET1^DIQ(100,ORD,1)
SET X("PROV")=$SELECT(X]"":X,1:"UNKNOWN")
+7 SET X=$$GET1^DIQ(100,ORD,21)
SET X("SD")=$SELECT(X]"":X,1:"UNKNOWN")
+8 ;Get only Active & Pending orders
SET X=$$GET1^DIQ(100,ORD,5)
if X'="ACTIVE"&(X'="PENDING")
QUIT
+9 SET X=$$GET1^DIQ(100,ORD,2)
if X["ALLERGY ENTER/EDIT"
QUIT
+10 ;next IF is for text orders with no orderable items
+11 ;IA 3800 allows direct global reads of ^OR(100,D0,.1
+12 if '$DATA(^OR(100,ORD,.1))
DO TEXTORD
+13 FOR II=0:0
SET II=$ORDER(^OR(100,ORD,.1,II))
if 'II
QUIT
Begin DoDot:3
+14 SET X(101.43)=$GET(^ORD(101.43,+^OR(100,ORD,.1,II,0),0))
SET X=$PIECE(X(101.43),U,5)
+15 ;Display group
SET X("DG")=$SELECT(X:$PIECE(^ORD(100.98,X,0),U),1:"UNKNOWN")
+16 SET X("ITEM")=$PIECE(X(101.43),U)
DO SET
End DoDot:3
End DoDot:2
End DoDot:1
+17 if '$DATA(^TMP($JOB))
SET ^TMP($JOB,0)="NONE FOUND"
SET R=$NAME(^TMP($JOB))
QUIT
TEXTORD NEW I,II,III,TO
SET X("DG")="Text Order"
SET X("ITEM")=""
+1 FOR I=0:0
SET I=$ORDER(^OR(100,ORD,8,I))
if 'I
QUIT
Begin DoDot:1
+2 FOR II=0:0
SET II=$ORDER(^OR(100,ORD,8,I,.1,II))
if 'II
QUIT
Begin DoDot:2
+3 SET X("ITEM")=X("ITEM")_" "_^OR(100,ORD,8,I,.1,II,0)
End DoDot:2
End DoDot:1
+4 if X("ITEM")]""
DO SET
QUIT
+5 ;
IM(R,DFN) ;Inpatient med list
+1 NEW DAYS,FLAG
SET DAYS=$PIECE(DFN,U,2)
SET DFN=+DFN
SET FLAG=0
DO AM^NUPAOBJ1(DAYS)
+2 KILL ^TMP($JOB)
FOR I=0:0
SET I=$ORDER(^TMP("NUPA",$JOB,I))
if 'I
QUIT
Begin DoDot:1
+3 if ^TMP("NUPA",$JOB,I,0)["IV Meds"
SET FLAG=1
if FLAG
SET ^TMP($JOB,I)=^TMP("NUPA",$JOB,I,0)
End DoDot:1
+4 KILL ^TMP("NUPA",$JOB)
SET R=$NAME(^TMP($JOB))
QUIT
+5 ;
CPH(R,DA) ;History of the whole care plan
+1 KILL ^TMP($JOB)
NEW C,I,II,REC,X
SET C=0
SET REC=$GET(^NUPA(1927.4,DA,0))
+2 DO SET1("Plan entered on "_$$D($PIECE(REC,U)))
+3 DO SET1("By: "_$SELECT($PIECE(REC,U,3):$$GET1^DIQ(200,$PIECE(REC,U,3),.01),1:"UNKNOWN"))
+4 IF '$DATA(^NUPA(1927.5,"B",DA))
DO SET1("")
DO SET1("No changes for this plan of care")
+5 FOR I=9E9:0
SET I=$ORDER(^NUPA(1927.5,"B",DA,I),-1)
if 'I
QUIT
Begin DoDot:1
+6 SET X=$GET(^NUPA(1927.5,I,0))
DO SET1("")
+7 DO SET1("Field "_$SELECT($PIECE(X,U,2):$PIECE(^DD(1927.4,$PIECE(X,U,2),0),U),1:"Unknown")_" was changed on")
+8 DO SET1($$D($PIECE(X,U,3))_" by "_$SELECT($PIECE(X,U,4):$$GET1^DIQ(200,$PIECE(X,U,4),.01),1:"UNKNOWN"))
+9 SET X=" Old value: "
if $PIECE($GET(^NUPA(1927.5,I,1,0)),U,3)=1
SET X=X_^NUPA(1927.5,I,1,1,0)
+10 DO SET1(X)
if $PIECE($GET(^NUPA(1927.5,I,1,0)),U,3)>1
Begin DoDot:2
+11 FOR II=0:0
SET II=$ORDER(^NUPA(1927.5,I,1,II))
if 'II
QUIT
DO SET1(" "_^NUPA(1927.5,I,1,II,0))
End DoDot:2
+12 SET X=" New value: "
if $PIECE($GET(^NUPA(1927.5,I,2,0)),U,3)=1
SET X=X_^NUPA(1927.5,I,2,1,0)
+13 DO SET1(X)
if $PIECE($GET(^NUPA(1927.5,I,2,0)),U,3)>1
Begin DoDot:2
+14 FOR II=0:0
SET II=$ORDER(^NUPA(1927.5,I,2,II))
if 'II
QUIT
DO SET1(" "_^NUPA(1927.5,I,2,II,0))
End DoDot:2
End DoDot:1
+15 SET R=$NAME(^TMP($JOB))
QUIT
+16 ;
DPH(R,DA,FLAG) ;Discharge planning comments
+1 ;FLAG=1: All comments. FLAG=2: Latest comment.
+2 NEW CNT,I,II,PROB
KILL ^TMP($JOB)
SET CNT=1
SET ^TMP($JOB,"LIST",1)="*** Prior comments ***"
+3 SET ^TMP($JOB,"LIST",2)=" NONE"
+4 FOR I=9E9:0
SET I=$ORDER(^NUPA(1927.6,"B",DA,I),-1)
if 'I
QUIT
Begin DoDot:1
+5 SET PROB=$PIECE($GET(^NUPA(1927.6,I,0)),U,2)
SET PROB("D")=$PIECE(^NUPA(1927.6,I,0),U,4)
if 'PROB
QUIT
+6 IF FLAG=1
DO DPHS(I)
QUIT
+7 if $DATA(^TMP($JOB,"SORT",PROB))
QUIT
SET ^TMP($JOB,"SORT",PROB)=I
End DoDot:1
+8 IF FLAG=2
FOR PROB=0:0
SET PROB=$ORDER(^TMP($JOB,"SORT",PROB))
if 'PROB
QUIT
DO DPHS(^TMP($JOB,"SORT",PROB))
+9 KILL ^TMP($JOB,"SORT")
SET R=$NAME(^TMP($JOB,"LIST"))
QUIT
DPHS(N) NEW II
SET CNT=CNT+1
SET ^TMP($JOB,"LIST",CNT)="Discharge planning issue: "_$PIECE($$GET1^DIQ(1927.41,PROB,.01),"*")
+1 FOR II=0:0
SET II=$ORDER(^NUPA(1927.6,N,1,II))
if 'II
QUIT
Begin DoDot:1
+2 SET CNT=CNT+1
SET ^TMP($JOB,"LIST",CNT)=^NUPA(1927.6,N,1,II,0)
End DoDot:1
+3 SET CNT=CNT+1
SET ^TMP($JOB,"LIST",CNT)="Comment added by "_$$GET1^DIQ(200,$PIECE($GET(^NUPA(1927.6,N,0)),U,3),.01)_" ("_$$GET1^DIQ(200,$PIECE($GET(^NUPA(1927.6,N,0)),U,3),8)_") on "_$$D1(PROB("D"))
+4 SET CNT=CNT+1
SET ^TMP($JOB,"LIST",CNT)=""
QUIT
+5 ;
UL(R,DA) ;List of pressure ulcers & other skin alterations for this care plan
+1 NEW C,NUPA,X
SET C=0
KILL ^TMP($JOB)
+2 FOR NUPA("I")=0:0
SET NUPA("I")=$ORDER(^NUPA(1927.401,"B",DA,NUPA("I")))
if 'NUPA("I")
QUIT
SET X=NUPA("I")
Begin DoDot:1
+3 ;No location
if $$GET1^DIQ(1927.401,NUPA("I"),1)=""
QUIT
+4 FOR NUPA("II")=1:1:7
if NUPA("II")'=4
SET X=X_U_$$GET1^DIQ(1927.401,NUPA("I"),NUPA("II"))
+5 DO SET1(X)
End DoDot:1
+6 SET R=$NAME(^TMP($JOB))
QUIT
+7 ;
SL(R,NUPADAT) ;Set pressure ulcers & other skin alterations for this care plan
+1 ;X(n)="A" or "P" ^ Care plan DA ^ Data 1 ^ Data 2 ^ Data 3 ^ # of lines of comments ^ Comments ^ Healed (1 or 0)
+2 NEW DA,DIC,DIE,DR,NUPA,NUPAALTS
SET (DIC,DIE)="^NUPA(1927.401,"
SET DIC(0)="L"
+3 FOR NUPA("I")=-1:0
SET NUPA("I")=$ORDER(NUPADAT(NUPA("I")))
if NUPA("I")=""
QUIT
Begin DoDot:1
+4 SET DA=-1
+5 FOR NUPA("II")=0:0
SET NUPA("II")=$ORDER(^NUPA(1927.401,"B",$PIECE(NUPADAT(NUPA("I")),U,2),NUPA("II")))
if 'NUPA("II")!(DA>0)
QUIT
Begin DoDot:2
+6 ;Type, Location check
if $PIECE(NUPADAT(NUPA("I")),U)="A"&($$GET1^DIQ(1927.401,NUPA("II"),5)=$PIECE(NUPADAT(NUPA("I")),U,3))&($$GET1^DIQ(1927.401,NUPA("II"),1)=$PIECE(NUPADAT(NUPA("I")),U,4))
SET DA=NUPA("II")
+7 if $PIECE(NUPADAT(NUPA("I")),U)="P"&($$GET1^DIQ(1927.401,NUPA("II"),5)="Pressure Ulcer")&($$GET1^DIQ(1927.401,NUPA("II"),1)=$PIECE(NUPADAT(NUPA("I")),U,3))
SET DA=NUPA("II")
End DoDot:2
+8 SET DR=""
+9 IF DA=-1
KILL DD,DO
SET X=$PIECE(NUPADAT(NUPA("I")),U,2)
DO FILE^DICN
SET DA=+Y
if $PIECE(NUPADAT(NUPA("I")),U)="P"
SET DR="5///Pressure Ulcer;"
+10 SET DR=DR_"1///"_$PIECE(NUPADAT(NUPA("I")),U,$SELECT($PIECE(NUPADAT(NUPA("I")),U)="A":4,1:3))
+11 IF $PIECE(NUPADAT(NUPA("I")),U)="A"
Begin DoDot:2
+12 SET DR=DR_";5///"_$PIECE(NUPADAT(NUPA("I")),U,3)_";6///"_$PIECE(NUPADAT(NUPA("I")),U,5)
+13 ;Healed
if $PIECE(NUPADAT(NUPA("I")),U,8)
SET DR=DR_";7///1"
End DoDot:2
+14 if $PIECE(NUPADAT(NUPA("I")),U)="P"
SET DR=DR_";2///"_$PIECE(NUPADAT(NUPA("I")),U,4)_";3///"_$PIECE(NUPADAT(NUPA("I")),U,5)
+15 DO ^DIE
+16 ;Comments
FOR NUPA("III")=1:1:$PIECE(NUPADAT(NUPA("I")),U,6)
Begin DoDot:2
+17 DO WPSET^NUPABCL(.R,"^NUPA(1927.401,"_DA_",1",NUPA("III"),$PIECE($PIECE(NUPADAT(NUPA("I")),U,7),"***",NUPA("III")))
End DoDot:2
End DoDot:1
+18 SET R=1
QUIT
+19 ;
IV(R,DA) ;List of IVs for this care plan
+1 NEW C,I,II,NUPADC
SET C=0
SET NUPADC=$PIECE(DA,U,2)
SET DA=+DA
KILL ^TMP($JOB)
+2 FOR I=0:0
SET I=$ORDER(^NUPA(1927.402,"B",DA,I))
if 'I
QUIT
SET X=I
Begin DoDot:1
+3 ;No location
if $$GET1^DIQ(1927.402,I,1)=""
QUIT
+4 ;I 'NUPADC Q:$$GET1^DIQ(1927.402,I,6)]"" ;D/Ced IVs
+5 FOR II=1:1:8,10:1:13
SET X=X_U_$$GET1^DIQ(1927.402,I,II)
+6 DO SET1(X)
End DoDot:1
+7 SET R=$NAME(^TMP($JOB))
QUIT
+8 ;
GC(R) ;Get component information
+1 KILL ^TMP($JOB)
NEW CNT,I,II,X
SET CNT=0
+2 FOR I=0:0
SET I=$ORDER(^NUPA(1927.41,I))
if 'I
QUIT
Begin DoDot:1
+3 FOR II=0:0
SET II=$ORDER(^NUPA(1927.41,I,1,II))
if 'II
QUIT
SET X=^NUPA(1927.41,I,1,II,0)
if $PIECE(X,U,3)
Begin DoDot:2
+4 SET CNT=CNT+1
SET ^TMP($JOB,CNT)=^NUPA(1927.41,I,0)_U_I_U_$PIECE(X,U,1,2)
End DoDot:2
End DoDot:1
+5 SET R=$NAME(^TMP($JOB))
QUIT
+6 ;
GI(R,DA) ;List of GI/GU devices for this care plan
+1 NEW C,I,II,X
SET C=0
KILL ^TMP($JOB)
+2 FOR I=0:0
SET I=$ORDER(^NUPA(1927.403,"B",DA,I))
if 'I
QUIT
SET X=I
Begin DoDot:1
+3 ;Removed
if $PIECE(^NUPA(1927.403,I,0),U,4)
QUIT
+4 FOR II=1,2,3,5
SET X=X_U_$$GET1^DIQ(1927.403,I,II)
+5 DO SET1(X)
End DoDot:1
+6 SET R=$NAME(^TMP($JOB))
QUIT
+7 ;
RAOK(R,DFN) ;Check if it's OK to show the update reassessment radiobuttons
+1 ;Must be at least one reassessment note since admission
+2 ;Note must be in last 24 hours
+3 NEW %DT,ADM,DA,H1,H2,NUPANOTX,NUPATIME,RANOTE,X,Y
+4 SET ADM=$PIECE($$LADM^NUPAOBJ(2),U)
IF ADM=0
SET R="0^NOT ADMITTED"
QUIT
+5 SET NUPANOTX=""
SET RANOTE=$$LN^NUPAOBJ("RN REASSESSMENT","1D")
+6 SET RANOTE=$GET(^TMP("NUPA",$JOB,1,0))
+7 ;None found
IF RANOTE["#0"
SET R="0^None in last 24 hours"
QUIT
+8 SET DA=$PIECE($PIECE(RANOTE,"#",2),")")
SET NUPATIME=$$GET1^DIQ(8925,DA,1201)
+9 SET RANOTE=$PIECE($PIECE(RANOTE,": ",2)," (")
SET RANOTE=$PIECE(RANOTE,":",1,2)
+10 SET %DT="R"
SET X=RANOTE
DO ^%DT
+11 SET H1=$$FMTH^XLFDT(Y)
SET X=$$HDIFF^XLFDT($HOROLOG,H1,3)
+12 SET R=$SELECT($EXTRACT(X):0,+$PIECE(X," ",2)>23:0,1:1)_U_NUPATIME
QUIT
+13 ;
HF(R) ;Get ONS Health Factors
+1 NEW C,DIC,NUPA,X,Y
SET C=0
KILL ^TMP($JOB),^TMP("DILIST",$JOB)
+2 DO FIND^DIC(9999999.64,"",.01,"P","ONS",9999)
+3 FOR NUPA("I")=0:0
SET NUPA("I")=$ORDER(^TMP("DILIST",$JOB,NUPA("I")))
if 'NUPA("I")
QUIT
Begin DoDot:1
+4 SET X=^TMP("DILIST",$JOB,NUPA("I"),0)
+5 if X["ONS AA"!(X["ONS RA")!(X["ONS TOBACCO")
DO SET1($PIECE(X,U,2)_U_$PIECE(X,U))
End DoDot:1
+6 ;S DIC="^AUTTHF(",DIC(0)="M"
+7 ;S X="LIFETIME NON-USER OF TOBACCO" D ^DIC D SET1($P(Y,U,2)_U_+Y)
+8 ;S X="FORMER TOBACCO USER" D ^DIC D SET1($P(Y,U,2)_U_+Y)
+9 ;S X="CURRENT TOBACCO USER" D ^DIC D SET1($P(Y,U,2)_U_+Y)
+10 KILL ^TMP($JOB,"SORT")
SET R=$NAME(^TMP($JOB))
QUIT
+11 ;
ALG(R,DFN) ;Get allergies
+1 NEW NUPA,GMRAL
SET NUPA("CNT")=0
+2 ;IA 10099
DO EN1^GMRADPT
+3 FOR NUPA("I")=0:0
SET NUPA("I")=$ORDER(GMRAL(NUPA("I")))
if 'NUPA("I")
QUIT
Begin DoDot:1
+4 SET NUPA("CNT")=NUPA("CNT")+1
SET R(NUPA("CNT"))=$PIECE(GMRAL(NUPA("I")),U,2)_U_NUPA("I")
End DoDot:1
+5 QUIT
APPTS(R,DFN) ;Get future appointments
+1 NEW NUPA,X,X1,X2
SET $PIECE(NUPA("SP")," ",20)=""
SET X1=DT
SET X2=365
DO C^%DTC
+2 SET NUPA(1)=DT_";"_X
SET NUPA(4)=DFN
SET NUPA("FLDS")="2;3;9"
SET NUPA("SORT")="P"
+3 ;IA 4433
SET NUPA("CNT")=0
SET CNT=$$SDAPI^SDAMA301(.NUPA)
+4 ;S ^TMP("NUPA",$J,1)="DATE CLINIC",^TMP("NUPA",$J,2)=""
+5 FOR NUPA("I")=0:0
SET NUPA("I")=$ORDER(^TMP($JOB,"SDAMA301",DFN,NUPA("I")))
if 'NUPA("I")
QUIT
Begin DoDot:1
+6 ;Cancelled
if $PIECE($PIECE(^TMP($JOB,"SDAMA301",DFN,NUPA("I")),U,3),";")["C"
QUIT
+7 SET NUPA("CNT")=NUPA("CNT")+1
SET ^TMP("NUPA",$JOB,NUPA("CNT"))=$EXTRACT($$D(NUPA("I"))_NUPA("SP"),1,20)_$PIECE($PIECE(^TMP($JOB,"SDAMA301",DFN,NUPA("I")),U,2),";",2)
End DoDot:1
+8 if NUPA("CNT")=0
SET ^TMP("NUPA",$JOB,1)="NONE"
+9 SET R=$NAME(^TMP("NUPA",$JOB))
QUIT
+10 ;
ACNOTE(R,DFN,NUPASTR) ;Create Audit C note text based on last administration
+1 NEW NUPA,NUPATEXT,X
SET NUPA("VIS")=""
SET NUPA("NEVER")=0
+2 SET NUPA("DA")=$ORDER(^YTT(601.84,"C",DFN,9E9),-1)
+3 IF 'NUPA("DA")
SET R(1)="No instrument administration on file"
QUIT
+4 SET NUPA("LOC")=$$GET1^DIQ(601.84,NUPA("DA"),13,"I")
+5 SET NUPATEXT(1)="Alcohol Use Disorders Identification Test Consumption (AUDC)"
+6 SET NUPATEXT(2)=""
+7 SET NUPATEXT(3)="Date Given: "_$PIECE($$GET1^DIQ(601.84,NUPA("DA"),3),"@")
+8 SET NUPATEXT(4)="Clinician: "_$$GET1^DIQ(601.84,NUPA("DA"),6)
+9 SET NUPATEXT(5)="Location: "_NUPA("LOC")
+10 SET NUPATEXT(6)=""
+11 SET NUPATEXT(7)="Veteran: "_$$GET1^DIQ(601.84,NUPA("DA"),1)
+12 SET NUPATEXT(8)="SSN: "_"xxx-xx-"_$EXTRACT($$GET1^DIQ(2,DFN,.09),6,9)
+13 SET NUPATEXT(9)="DOB: "_$$GET1^DIQ(2,DFN,.03)_" ("_$$GET1^DIQ(2,DFN,.033)_")"
+14 SET NUPATEXT(10)="Gender: "_$$GET1^DIQ(2,DFN,.02)
+15 SET NUPATEXT(11)=""
+16 SET NUPATEXT(12)=""
+17 SET NUPATEXT(13)=" AUDC Score: "_$PIECE($PIECE(NUPASTR,U,4),"~",2)_" points"
+18 SET NUPATEXT(14)=""
+19 SET NUPATEXT(15)="In men, a score of 4 or more is considered positive; in women, a score of 3 or "
+20 SET NUPATEXT(16)="more is considered positive."
+21 SET NUPATEXT(17)=""
+22 SET NUPATEXT(18)=" Questions and Answers"
+23 SET NUPATEXT(19)=""
SET NUPA("CNT")=19
SET NUPASTR=$PIECE(NUPASTR,U,5)
+24 FOR NUPA("I")=2:1
if $PIECE(NUPASTR,"*",NUPA("I"))=""
QUIT
Begin DoDot:1
+25 if NUPA("I")=2&($PIECE($PIECE(NUPASTR,"*",NUPA("I")),"~",2)["Never")
SET NUPA("NEVER")=1
+26 SET NUPA("CNT")=NUPA("CNT")+1
SET NUPATEXT(NUPA("CNT"))=$PIECE($PIECE(NUPASTR,"*",NUPA("I")),"~")
+27 SET NUPA("CNT")=NUPA("CNT")+1
SET NUPATEXT(NUPA("CNT"))=" "_$PIECE($PIECE(NUPASTR,"*",NUPA("I")),"~",2)
+28 if NUPA("I")>2&(NUPA("NEVER"))
SET NUPATEXT(NUPA("CNT"))=" Not asked (patient reports no drinking in past year)"
End DoDot:1
+29 SET NUPA("CNT")=NUPA("CNT")+1
SET NUPATEXT(NUPA("CNT"))=""
+30 SET NUPA("CNT")=NUPA("CNT")+1
SET NUPATEXT(NUPA("CNT"))="Information contained in this note is based on a self report assessment and is"
+31 SET NUPA("CNT")=NUPA("CNT")+1
SET NUPATEXT(NUPA("CNT"))="not sufficient to use alone for diagnostic purposes. Assessment results should"
+32 SET NUPA("CNT")=NUPA("CNT")+1
SET NUPATEXT(NUPA("CNT"))="be verified for accuracy and used in conjunction with other diagnostic activities."
+33 MERGE R=NUPATEXT
QUIT
NOTENM() ;IEN & name of Note Title
QUIT "1781^MENTAL HEALTH DIAGNOSTIC STUDY NOTE"
+1 ;
SET SET C=C+1
SET ^TMP($JOB,X("DG"),X("SD"),ORD,C)=X("DG")_U_X("ITEM")_U_X("SD")_U_X("PROV")
QUIT
SET1(X) SET C=C+1
SET ^TMP($JOB,C)=X
QUIT
D(Y) DO DD^%DT
QUIT Y
D1(Y) DO DD^%DT
QUIT $PIECE(Y,"@")_" on "_$PIECE(Y,"@",2)
