- 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 Jan 18, 2025@03:24:53 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)