Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: NUPABCL2

NUPABCL2.m

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