- PSJBCMA ;BIR/MV-RETURN INPATIENT ACTIVE MEDS (CONDENSED) ; 5/4/16 10:51am
- ;;5.0;INPATIENT MEDICATIONS ;**32,41,46,57,63,66,56,69,58,81,91,104,111,112,186,159,173,190,113,225,253,267,279,308,318,315,364**;16 DEC 97;Build 47
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ; Reference to ^PS(50.7 is supported by DBIA 2180.
- ; Reference to ^PS(51 is supported by DBIA 2176.
- ; Reference to ^PS(51.1 is supported by DBIA 2177.
- ; Reference to ^PS(51.2 is supported by DBIA 2178.
- ; Reference to ^PS(52.6 is supported by DBIA 1231.
- ; Reference to ^PS(52.7 is supported by DBIA 2173.
- ; Reference to ^PS(55 is supported by DBIA 2191.
- ; Reference to ^PSDRUG is supported by DBIA 2192.
- ; Reference to ^VADPT is supported by DBIA 10061.
- ; Reference to ^XLFDT is supported by DBIA 10103
- ; Usage of this routine by BCMA is supported by DBIA 2828.
- ;
- ;*267 - add new piece of info to return TMP global. Need the Med
- ; route IEN per each order.
- ;*279 - add Clinic name, IEN to pieces 11, 12 of TMP("PSJ",$J,0)
- ; - add High Risk drug Witness indicator to Results 7th piece
- ;*315 - add BCMA removal flag to 7th piece of 700 node
- ;*364 - add Hazardous Handle & Dispose flags to Unit Dose and IV drug TMP globals
- ;
- EN(DFN,BDT,OTDATE) ; return condensed list of inpatient meds
- NEW CNT,DN,F,FON,ON,PST,WBDT,X,X1,X2,Y,%
- D:+$G(DFN) ORDER
- I '$D(^TMP("PSJ",$J,1,0)) S ^(0)=-1
- K PSJINX
- Q
- ORDER ;Loop thru orders.
- I '+$G(BDT) D NOW^%DTC S BDT=%
- I BDT'["." S BDT=BDT_".0001"
- S PSJINX=0
- ;U/D orders
- S F="^PS(55,DFN,5,",WBDT=BDT
- F S WBDT=$O(^PS(55,DFN,5,"AUS",WBDT)) Q:'WBDT D
- . F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",WBDT,ON)) Q:'ON S FON=ON_"U",PSJON(FON)="" D UDVAR
- ;IV orders
- S F="^PS(55,DFN,""IV"",",WBDT=BDT
- F S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT D
- . F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON S FON=ON_"V",PSJON(FON)="" D IVVAR
- ;Pending orders
- S F="^PS(53.1,"
- F PST="P","N" F ON=0:0 S ON=$O(^PS(53.1,"AS",PST,DFN,ON)) Q:'ON D
- . S FON=ON_"P"
- . S X=$P($G(^PS(53.1,+ON,0)),U,4) D @$S(X="F":"IVVAR",1:"UDVAR")
- ;When a one-time order is found, check against PSJON(FON) array to
- ;make sure no duplicates return on ^TMP.
- I '+$G(OTDATE) D NOW^%DTC S X1=$E(%,1,12),X2=-30 D C^%DTC S OTDATE=X
- I OTDATE'["." S OTDATE=OTDATE_".0001"
- Q:BDT'>OTDATE
- S F="^PS(55,DFN,5,",WBDT=OTDATE
- F S WBDT=$O(^PS(55,DFN,5,"AU","O",WBDT)) Q:'WBDT D
- . F ON=0:0 S ON=$O(^PS(55,DFN,5,"AU","O",WBDT,ON)) Q:'ON D
- .. S FON=ON_"U" D:'$D(PSJON(FON)) UDVAR
- S F="^PS(55,DFN,""IV"",",WBDT=OTDATE
- F S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT D
- . F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON D
- .. S X=$P($G(^PS(55,DFN,"IV",ON,0)),U,9)
- .. I X]"",$$ONE(DFN,ON_"V",X,$P(X,"^",2),$P(X,"^",3))="O" D
- ... S FON=ON_"V" D:'$D(PSJON(FON)) IVVAR
- K PSJON,PSJBCID
- Q
- ;
- UDVAR ;Set ^TMP for Unit dose & Pending orders
- N CLINIC
- D UDPEND I '$$CLINICS($G(CLINIC)) Q
- D TMP
- ;Setup Dispense drug for ^TMP
- S CNT=0 D NOW^%DTC
- F X=0:0 S X=$O(@(F_ON_",1,"_X_")")) Q:'X D
- . S PSJDD=@(F_ON_",1,"_X_",0)") I $P(PSJDD,"^",3)]"",$P(PSJDD,"^",3)'>% Q
- .;*225 Don't allow 0
- . I +$P(PSJDD,"^",2)=0 S $P(PSJDD,"^",2)=1
- . S CNT=CNT+1
- . S ^TMP("PSJ",$J,PSJINX,700,CNT,0)=+PSJDD_U_$P($G(^PSDRUG(+PSJDD,0)),U)_U_$S((FON["U")&($P(PSJDD,U,2)=""):1,(FON["U")&($E($P(PSJDD,U,2))="."):"0"_$P(PSJDD,U,2),1:$P(PSJDD,U,2))_U_$P(PSJDD,U,3)
- . ;add High Risk field to 6th piece of 700 (disp drug) ;*279
- . S $P(^TMP("PSJ",$J,PSJINX,700,CNT,0),U,6)=$$GET1^DIQ(50.7,PSJ("OI"),1,"I")
- . ;add Prompt For Removal In BCMA fld to 7th ;*315
- . S $P(^TMP("PSJ",$J,PSJINX,700,CNT,0),U,7)=+PSJ("MRRFL")
- . ;add Haz Handle & Dispose flags at 8 & 9th pieces *364
- . S $P(^TMP("PSJ",$J,PSJINX,700,CNT,0),U,8,9)=$P($$HAZ^PSSUTIL(+PSJDD),U,1,2)
- S:CNT ^TMP("PSJ",$J,PSJINX,700,0)=CNT
- K PSJ,PSJDD
- Q
- ;
- IVVAR ;Set variables for IV and pending orders
- NEW ND,X,Y,CLINIC,DDIEN
- I FON["P" D UDPEND Q:'$$CLINICS(CLINIC) S PSJ("INFRATE")=$P($P($G(^PS(53.1,ON,8)),U,5),"@")
- I FON["V" D Q:'$$CLINICS(CLINIC)
- . S X=$G(^PS(55,DFN,"IV",ON,0)),CLINIC=$G(^("DSS")) Q:'$$CLINICS(CLINIC)
- . S PSJ("STARTDT")=$P(X,U,2),PSJ("STOPDT")=$P(X,U,3)
- . S PSJ("INFRATE")=$P($P(X,U,8),"@"),PSJ("SCHD")=$P(X,U,9)
- . S PSJ("ADM")=$P(X,U,11),PSJ("AUTO")=$P(X,U,12),PSJ("STATUS")=$P(X,U,17)
- . S PSJ("IVTYPE")=$P(X,U,4),PSJ("INSYR")=$P(X,U,5)
- . S PSJ("CPRS")=$P(X,U,21),PSJ("CHEMO")=$P(X,U,23)
- . S X=$G(^PS(55,DFN,"IV",ON,.2))
- . S PSJ("DO")="",PSJ("MR")=$P(X,U,3),PSJ("PRI")=$P(X,U,4),PSJ("FLG")=$P(X,U,7),PSJ("COM")="",PSJ("SRC")=""
- . I PSJ("FLG") D
- .. N S1,A,B,C
- .. S S1="" F S S1=$O(^PS(55,DFN,"IV",ON,"A",S1),-1) Q:'S1 S C=$G(^(S1,0)) S A=$P(C,U,2),B=$P(C,U,4) Q:A="UG" D I PSJ("SRC")]"" Q
- ... Q:A'="G"
- ... S PSJ("SRC")=$S(B["FLAGGED BY PHARM":"PHARMACIST",B["FLAGGED BY CPRS":"CPRS",1:"")
- ... S PSJ("COM")=$P(B," ",4,99)
- . S PSJ("OI")=+X
- . S X=$G(^PS(55,DFN,"IV",ON,2))
- . S PSJ("PREV")=$P(X,U,5) I PSJ("PREV")["V",(+PSJ("PREV")=+ON) S PSJ("PREV")=""
- . S PSJ("FOLLOW")=$P(X,U,6),PSJ("RFO")=$P(X,U,9) I PSJ("FOLLOW")["V",(+PSJ("FOLLOW")=+ON) S (PSJ("FOLLOW"),PSJ("RFO"))=""
- . S PSJ("SIOPI")=$S($P($G(^PS(55,DFN,"IV",+ON,3)),"^",2)&($P($G(^PS(55,DFN,"IV",+ON,3)),"^")'=""):"!",1:"")_$P($G(^(3)),"^")
- . N SCHD S SCHD=PSJ("SCHD")
- . S PSJ("STC")=$$ONE(DFN,ON_"V",SCHD,PSJ("STARTDT"),PSJ("STOPDT"))
- . I PSJ("STC")=""!(PSJ("STC")="C") S PSJ("STC")=$S(SCHD["PRN":"P",1:"C")
- . I PSJ("STC")="C" S PSJ("STC")=$S($$ONCALL(SCHD):"OC",1:"C")
- D TMP
- S CNT=0
- F X=0:0 S X=$O(@(F_ON_",""AD"","_X_")")) Q:'X D
- . S ND=$G(@(F_ON_",""AD"","_X_",0)")),DN=$G(^PS(52.6,+ND,0))
- . S CNT=CNT+1,^TMP("PSJ",$J,PSJINX,850,CNT,0)=+ND_U_$P(DN,U)_U_$P(ND,U,2)_U_$P(ND,U,3)
- . ;add High Risk field to 6th piece of 850 (additv) ;*279
- . S $P(^TMP("PSJ",$J,PSJINX,850,CNT,0),U,6)=$$HRFLG(+ND,"A")
- . ;add Haz Handle & Dispose flags at 7 & 8th pieces of additive *364
- . S DDIEN=+$P($G(^PS(52.6,+ND,0)),U,2)
- . S $P(^TMP("PSJ",$J,PSJINX,850,CNT,0),U,7,8)=$P($$HAZ^PSSUTIL(DDIEN),U,1,2)
- S:CNT ^TMP("PSJ",$J,PSJINX,850,0)=CNT,CNT=0
- F X=0:0 S X=$O(@(F_ON_",""SOL"","_X_")")) Q:'X D
- . S ND=$G(@(F_ON_",""SOL"","_X_",0)")),DN=$G(^PS(52.7,+ND,0))
- . S CNT=CNT+1,^TMP("PSJ",$J,PSJINX,950,CNT,0)=+ND_U_$P(DN,U)_U_$P(ND,U,2)_U_$P(DN,U,4)
- . ;add High Risk field to 6th piece of 950 (sol) ;*279
- . S $P(^TMP("PSJ",$J,PSJINX,950,CNT,0),U,6)=$$HRFLG(+ND,"S")
- . ;add Haz Handle & Dispose flags at 7 & 8th pieces of additive *364
- . S DDIEN=+$P($G(^PS(52.7,+ND,0)),U,2)
- . S $P(^TMP("PSJ",$J,PSJINX,950,CNT,0),U,7,8)=$P($$HAZ^PSSUTIL(DDIEN),U,1,2)
- S:CNT ^TMP("PSJ",$J,PSJINX,950,0)=CNT
- K PSJ
- S X1=0
- F S X1=$O(^PS(55,DFN,"IVBCMA",X1)) Q:'X1 D
- . S XX=$G(^PS(55,DFN,"IVBCMA",X1,0)) Q:ON'=$P(XX,"^",2) S PSJBCID=$P(XX,"^"),X2=0
- . F I=1:1 S X2=$O(^PS(55,DFN,"IVBCMA",X1,"AD",X2)) Q:'X2 D
- .. S X=^(X2,0),^TMP("PSJ",$J,PSJINX,800,PSJBCID,I)=+X_"^"_$S($D(^PS(52.6,+X,0)):$P(^(0),"^"),1:"*****")_"^"_$P(X,"^",2,99)
- .. ;add High Risk field to 6th piece of 800 (additv) ;*279
- .. S $P(^TMP("PSJ",$J,PSJINX,800,PSJBCID,I),U,6)=$$HRFLG(+ND,"A")
- . I I>1 S ^TMP("PSJ",$J,PSJINX,800,PSJBCID,0)=I-1
- . S X2=0
- . F I=1:1 S X2=$O(^PS(55,DFN,"IVBCMA",X1,"SOL",X2)) Q:'X2 D
- .. S X=^(X2,0),^TMP("PSJ",$J,PSJINX,900,PSJBCID,I)=$P(X,"^")_"^"_$S($D(^PS(52.7,$P(X,"^"),0)):$P(^(0),"^"),1:"*****")_"^"_$P(X,"^",2,99)
- .. ;add High Risk field to 6th piece of 900 (sol) ;*279
- .. S $P(^TMP("PSJ",$J,PSJINX,900,PSJBCID,I),U,6)=$$HRFLG(+X,"S")
- . I I>1 S ^TMP("PSJ",$J,PSJINX,900,PSJBCID,0)=I-1
- Q
- ;
- UDPEND ;
- S X=$G(@(F_ON_",0)")) I $P(F,",")[53.1 S CLINIC=$G(@(F_ON_",""DSS"")")) Q:'$$CLINICS(CLINIC)
- I $P(F,",")[55 S CLINIC=$G(@(F_ON_",8)")) Q:'$$CLINICS(CLINIC)
- S PSJ("MR")=$P(X,U,3),PSJ("SM")=$P(X,U,5),PSJ("HSM")=$P(X,U,6)
- S PSJ("ST")=$P(X,U,7),PSJ("STATUS")=$P(X,U,9)
- S PSJ("CPRS")=$P(X,U,21),PSJ("PREV")=$P(X,U,25),PSJ("FOLLOW")=$P(X,U,26),PSJ("RFO")=$P(X,U,27)
- S:FON["U" PSJ("NGIVEN")=$P(X,U,22)
- S X=$G(@(F_ON_",.2)"))
- S PSJ("DO")=$P(X,U,2),PSJ("PRI")=$P(X,U,4),PSJ("FLG")=$P(X,U,7),PSJ("COM")="",PSJ("SRC")=""
- I PSJ("FLG") D
- . N S1,A,B,C
- . S S1="" F S S1=$O(^PS(55,DFN,5,ON,9,S1),-1) Q:'S1 S C=$G(^(S1,0)) S A=$P(C,U,3),B=$P(C,U,4) Q:A=7010!(A=7030) D I PSJ("SRC")]"" Q
- .. Q:A'=7000&(A'=7020)
- .. S PSJ("SRC")=$S(A=7000:"PHARMACIST",A=7020:"CPRS",1:"")
- .. S PSJ("COM")=$G(@(F_ON_",13)"))
- S PSJ("OI")=+X
- S X=$G(@(F_ON_",2)"))
- S PSJ("SCHD")=$P(X,U),PSJ("STARTDT")=$P(X,U,2)
- S PSJ("PRSTOPDT")=$P(X,U,3) ;*315 prev stop date for one times
- S PSJ("STOPDT")=$P(X,U,4),PSJ("ADM")=$P(X,U,5)
- S PSJ("FREQ")=$P(X,U,6) ;*315
- ;save Duration & MRR code from 2.1 / convert code 2 = 1 or 3 ;*315
- S X=$G(@(F_ON_",2.1)"))
- S PSJ("DOA")=$P(X,U),PSJ("RMTM")=$P(X,U,2),PSJ("MRRFL")=+$P(X,U,4)
- I PSJ("MRRFL")=2 S PSJ("MRRFL")=$S(PSJ("DOA")>0:3,1:1)
- ;if DOA is null, but FREQ exists, then use FREQ as DOA when...
- S PSJ("DOA")=$S(PSJ("DOA")<1:$G(PSJ("FREQ")),1:PSJ("DOA"))
- ;
- S X=$G(@(F_ON_",4)"))
- S PSJ("AUTO")=$P(X,U,11)
- ;naked reference on line below refers to full reference created by indirect reference to F_ON, where F may refer to ^PS(53.1 or the IV or UD multiple ^PS(55
- S PSJ("SIOPI")=$S($P($G(@(F_ON_",6)")),"^",2)&($P($G(@(F_ON_",6)")),"^")'=""):"!",1:"")_$$ENSET($P($G(^(6)),"^"))
- D SIOPI
- S PSJ("STC")=PSJ("ST")
- I PSJ("ST")="R"!(PSJ("ST")="C") S PSJ("STC")=$S(PSJ("SCHD")["PRN":"P",$$ONCALL(PSJ("SCHD")):"OC",$$ONE(DFN,FON,PSJ("SCHD"))="O":"O",1:"C")
- Q
- ;
- TMP ;Setup ^TMP that have common fields between IV and U/D
- N A,CLNAME,CLNAMPTR ;*279
- S PSJINX=PSJINX+1
- S PSJ("OINAME")=$$OIDF^PSJLMUT1(+PSJ("OI")) I PSJ("OINAME")["NOT FOUND" S PSJ("OINAME")=""
- S PSJ("OIDF")=$$GET1^DIQ(50.7,+PSJ("OI"),.02)
- I PSJ("OINAME")="" S PSJ("OIDF")=""
- S A=$G(^PS(51.2,+PSJ("MR"),0)),PSJ("MRABB")=$P(A,U,3),PSJ("MRNM")=$P(A,U)
- S ^TMP("PSJ",$J,PSJINX,0)=DFN_U_+ON_U_FON_U_PSJ("PREV")_U_PSJ("FOLLOW")_U_$G(PSJ("IVTYPE"))_U_$G(PSJ("INSYR"))_U_$G(PSJ("CHEMO"))_U_PSJ("CPRS")_U_$G(PSJ("RFO"))
- ;add Clinic name & IEN ptr to TMP 0 node (pieces 11,12) *279
- ;piece 11 determines if order is a CO or IM for BCMA VDL's *279
- I +CLINIC,$$CLINIC(CLINIC) D ;CL IEN & valid appt date *279
- . S CLNAMPTR=$O(^PS(53.46,"B",+CLINIC,""))
- . S CLNAME=$$GET1^DIQ(53.46,CLNAMPTR_",",.01)
- . S $P(^TMP("PSJ",$J,PSJINX,0),U,11)=CLNAME ;CO ind, CO NAME
- . S $P(^TMP("PSJ",$J,PSJINX,0),U,12)=+CLINIC ;IEN ptr to file 44
- ;
- S ^TMP("PSJ",$J,PSJINX,1)=PSJ("MRABB")_U_PSJ("STC")_U_$G(PSJ("SCHD"))_U_PSJ("STARTDT")_U_PSJ("STOPDT")_U_PSJ("ADM")_U_PSJ("STATUS")_U_$G(PSJ("NGIVEN"))_U_$G(PSJ("ST"))_U_$G(PSJ("AUTO"))
- ;add DOA, Remove Times, MRR code, & prev stop DT to pieces 12-15 *315
- S $P(^TMP("PSJ",$J,PSJINX,1),U,12)=$G(PSJ("DOA"))
- S $P(^TMP("PSJ",$J,PSJINX,1),U,13)=$G(PSJ("RMTM"))
- S $P(^TMP("PSJ",$J,PSJINX,1),U,14)=$G(PSJ("MRRFL"))
- S $P(^TMP("PSJ",$J,PSJINX,1),U,15)=$G(PSJ("PRSTOPDT"))
- ;
- S ^TMP("PSJ",$J,PSJINX,1,0)=$P(A,U,8)_U_PSJ("MRNM")_U_$P(A,U,9)_U_+PSJ("MR") ;*267 append file 51.2 ien
- S ^TMP("PSJ",$J,PSJINX,2)=PSJ("DO")_U_$P($G(PSJ("INFRATE")),"@")_U_$G(PSJ("SM"))_U_$G(PSJ("HSM"))
- S ^TMP("PSJ",$J,PSJINX,3)=PSJ("OI")_U_PSJ("OINAME")_U_PSJ("OIDF")
- S ^TMP("PSJ",$J,PSJINX,4)=PSJ("SIOPI")
- S A=$$SNDTSTA^PSJHL4A(PSJ("PRI"),PSJ("SCHD"))
- S ^TMP("PSJ",$J,PSJINX,5)=$S(A=1:0,1:1)_U_PSJ("FLG")_U_PSJ("SRC")_U_PSJ("COM")
- Q
- ;
- SIOPI ; Use provider comments if order is pending and there is no SI
- NEW X,Y,Z
- I FON["P",(PSJ("SIOPI")=""),$O(^PS(53.1,+ON,12,0)) D
- . F X=0:0 S X=$O(^PS(53.1,+ON,12,X)) Q:'X S Z=$G(^(X,0)) D
- .. S Y=$L(PSJ("SIOPI"))
- .. S:Y+$L(Z)'>179 PSJ("SIOPI")=PSJ("SIOPI")_Z_""
- . I Y+$L(Z)>179 S PSJ("SIOPI")="SEE PROVIDER COMMENTS"
- Q
- ;
- ENSET(X) ; expands SPECIAL INSTRUCTIONS field contained in X into Y
- N X1,X2,Y S Y=""
- F X1=1:1:$L(X," ") S X2=$P(X," ",X1) I X2]"" S Y=Y_$S($L(X2)>30:X2,'$D(^PS(51,+$O(^PS(51,"B",X2,0)),0)):X2,$P(^(0),"^",2)]""&$P(^(0),"^",4):$P(^(0),"^",2),1:X2)_" "
- S Y=$E(Y,1,$L(Y)-1)
- Q Y
- ;
- ONE(DFN,ORD,SCH,START,STOP) ;Determine if order is one-time, and return schedule type
- ; Input: DFN - patient's IEN
- ; ORD - order number
- ; SCH - schedule text (required)
- ; START - order start date (optional)
- ; STOP - order stop date (optional)
- N X,ONEFRQ,TYP,T
- I $G(PSJ("PREV")),$G(PSJ("FOLLOW")) I +PSJ("PREV")=+PSJ("FOLLOW") S (PSJ("PREV"),PSJ("FOLLOW"))=""
- ; PSJ*5*190 One-Time PRN
- I $G(SCH)="",$G(DFN),$G(ORD) D
- .I ORD["U" S SCH=$P($G(^PS(55,DFN,5,+ORD,2)),"^")
- .I ORD["V" S SCH=$P($G(^PS(55,DFN,"IV",+ORD,0)),"^",9)
- I $G(SCH)]"",$$OTPRN^PSJBCMA3(SCH)="O" Q "O"
- I $G(DFN)]"",$G(ORD)]"",ORD["U",$P(^PS(55,DFN,5,+ORD,0),"^",7)'="R" Q $P(^PS(55,DFN,5,+ORD,0),"^",7)
- I $G(SCH)="" Q ""
- ; PSJ*5*113 Determine schedule type from ^PS(51.1, not from schedule name.
- I $D(^PS(51.1,"AC","PSJ",SCH)) S X=$O(^(SCH,"")) S X=$P(^PS(51.1,X,0),"^",5) Q $S(X="D":"C",1:X)
- I $G(START)]"",$G(STOP)]"",START=STOP Q "O"
- I $$DAY(SCH) Q "C"
- Q ""
- ;
- CLINIC(CL) ; is a valid appointment date present? 1=yes 0 =no
- I $P(CL,"^",2)?7N!($P(CL,"^",2)?7N1".".N) Q 1
- Q 0
- ;
- CLINICS(CL,IGNOSND) ;IM & CO order tests *70
- ; Send IM orders always. Send Clinic orders as CO order, if it
- ; meets below conditions, else send the order over as a IM order.
- ;
- ; If CPRS sends the Clinic IEN and the appointment date when the
- ; order is signed in CPRS, then this is a Clinic order and can be
- ; sent to BCMA as a CO order, if it passes the 53.46 test as well.
- ;
- ; IGNOSND = Flag indicating the SEND TO BCMA parameter should be ignored.
- ; PSJHYBR = Hybrid order - contains reference to CLINIC, but no appointment date time
- ; Function Return values: 1 = Send order to BCMA
- ; 0 = Do Not send order to BCMA
- ; * Orders with Clinic but no Appt should only be sent if patient is admitted or SEND TO BCMA flag set
- I '$G(CL)!$G(IGNOSND) Q 1
- N PSJVAIN4,X,PSJCNT,PSJSTRT,PSJSTOP,VAIP S PSJVAIN4=1 I $G(DFN) D
- .N VAIN,PSGP S PSGP=DFN D INP^VADPT I '$G(VAIN(4)) S PSJVAIN4=0 I $G(PSBRPT(".1"))'="" D ;add code check for historical data when running BCMA
- ..S PSJSTOP=$P(PSBRPT(".1"),U,8),PSJSTRT=$P(PSBRPT(".1"),U,6) Q:'PSJSTOP!'(PSJSTRT)
- ..S PSJCNT=PSJSTRT F Q:PSJCNT>PSJSTOP S VAIP("D")=PSJCNT D IN5^VADPT S:+VAIP("3") PSJVAIN4=1 S PSJCNT=$$FMADD^XLFDT(PSJCNT,1) Q:$G(PSJVAIN4) ;check to see if patient was admitted during time frame of report
- .I 'PSJVAIN4,$G(PSBREC(2)),$G(PSBREC(0))="ADMLKUP" S VAIP("D")=PSBREC(2) D IN5^VADPT S:+VAIP("3") PSJVAIN4=1 ;return patient data for Edit med log option if patient was admitted when med log entry was recorded
- .I 'PSJVAIN4,$G(PSBPRNDT) S VAIP("D")=$P(PSBSTRT,".") D IN5^VADPT S:+VAIP("3") PSJVAIN4=1 ;*318
- .I 'PSJVAIN4,($G(PSBTYPE)="PM"),$G(PSJ("STARTDT")) S VAIP("D")=$P(PSJ("STARTDT"),".") D IN5^VADPT S:+VAIP("3") PSJVAIN4=1 ;*318
- I $G(PSJVAIN4) Q:'$$CLINIC(CL) 1 ;no valid appt date
- N A
- S A=$O(^PS(53.46,"B",+CL,"")) Q:'A 0
- Q:'$D(^PS(53.46,"B",+CL)) 0
- Q $P(^PS(53.46,A,0),"^",4) ;send to bcma? flag
- ;
- DAY(SCH) ;determine if this is a 'day of the week' schedule
- I $G(SCH)="" Q 0
- N D,DAY,DAYS,I,X
- S DAYS="SUNDAY,MONDAY,TUESDAY,WEDNESDAY,THURSDAY,FRIDAY,SATURDAY"
- F I=1:1 S D=$P(SCH,"-",I) Q:D="" D Q:X=0
- . S X=0 F J=1:1:7 S DAY=$P(DAYS,",",J) D Q:X=1
- .. I D=$E(DAY,1,$L(D)) S X=1
- Q X
- ;
- ONCALL(SCHD) ; Check if a schedule is type On Call (all "APPSJ" schedules with a given name must have the same schedule type)
- N NXT,SCHARR,OCCHK
- S OCCHK=0
- Q:$G(SCHD)="" OCCHK
- Q:'$D(^PS(51.1,"APPSJ",SCHD)) OCCHK
- S NXT=0 F S NXT=$O(^PS(51.1,"APPSJ",SCHD,NXT)) Q:'NXT S TYP=$P($G(^PS(51.1,+NXT,0)),"^",5) S:TYP]"" SCHARR(TYP)=""
- I '$D(SCHARR("OC")) S OCCHK=0 Q OCCHK
- I $O(SCHARR("OC"))]""!($O(SCHARR("OC"),-1)]"") S OCCHK=0 Q OCCHK
- I $D(SCHARR("OC")) S OCCHK=1
- Q OCCHK
- ;
- HRFLG(IEN,ADDSOL) ;Get High Risk flag for this Orderable Item
- N OIIEN
- S:ADDSOL="A" OIIEN=+$$GET1^DIQ(52.6,IEN,15,"I")
- S:ADDSOL="S" OIIEN=+$$GET1^DIQ(52.7,IEN,9,"I")
- Q +$$GET1^DIQ(50.7,OIIEN,1,"I")
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJBCMA 16420 printed Jan 18, 2025@03:07:27 Page 2
- PSJBCMA ;BIR/MV-RETURN INPATIENT ACTIVE MEDS (CONDENSED) ; 5/4/16 10:51am
- +1 ;;5.0;INPATIENT MEDICATIONS ;**32,41,46,57,63,66,56,69,58,81,91,104,111,112,186,159,173,190,113,225,253,267,279,308,318,315,364**;16 DEC 97;Build 47
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ; Reference to ^PS(50.7 is supported by DBIA 2180.
- +4 ; Reference to ^PS(51 is supported by DBIA 2176.
- +5 ; Reference to ^PS(51.1 is supported by DBIA 2177.
- +6 ; Reference to ^PS(51.2 is supported by DBIA 2178.
- +7 ; Reference to ^PS(52.6 is supported by DBIA 1231.
- +8 ; Reference to ^PS(52.7 is supported by DBIA 2173.
- +9 ; Reference to ^PS(55 is supported by DBIA 2191.
- +10 ; Reference to ^PSDRUG is supported by DBIA 2192.
- +11 ; Reference to ^VADPT is supported by DBIA 10061.
- +12 ; Reference to ^XLFDT is supported by DBIA 10103
- +13 ; Usage of this routine by BCMA is supported by DBIA 2828.
- +14 ;
- +15 ;*267 - add new piece of info to return TMP global. Need the Med
- +16 ; route IEN per each order.
- +17 ;*279 - add Clinic name, IEN to pieces 11, 12 of TMP("PSJ",$J,0)
- +18 ; - add High Risk drug Witness indicator to Results 7th piece
- +19 ;*315 - add BCMA removal flag to 7th piece of 700 node
- +20 ;*364 - add Hazardous Handle & Dispose flags to Unit Dose and IV drug TMP globals
- +21 ;
- EN(DFN,BDT,OTDATE) ; return condensed list of inpatient meds
- +1 NEW CNT,DN,F,FON,ON,PST,WBDT,X,X1,X2,Y,%
- +2 if +$GET(DFN)
- DO ORDER
- +3 IF '$DATA(^TMP("PSJ",$JOB,1,0))
- SET ^(0)=-1
- +4 KILL PSJINX
- +5 QUIT
- ORDER ;Loop thru orders.
- +1 IF '+$GET(BDT)
- DO NOW^%DTC
- SET BDT=%
- +2 IF BDT'["."
- SET BDT=BDT_".0001"
- +3 SET PSJINX=0
- +4 ;U/D orders
- +5 SET F="^PS(55,DFN,5,"
- SET WBDT=BDT
- +6 FOR
- SET WBDT=$ORDER(^PS(55,DFN,5,"AUS",WBDT))
- if 'WBDT
- QUIT
- Begin DoDot:1
- +7 FOR ON=0:0
- SET ON=$ORDER(^PS(55,DFN,5,"AUS",WBDT,ON))
- if 'ON
- QUIT
- SET FON=ON_"U"
- SET PSJON(FON)=""
- DO UDVAR
- End DoDot:1
- +8 ;IV orders
- +9 SET F="^PS(55,DFN,""IV"","
- SET WBDT=BDT
- +10 FOR
- SET WBDT=$ORDER(^PS(55,DFN,"IV","AIS",WBDT))
- if 'WBDT
- QUIT
- Begin DoDot:1
- +11 FOR ON=0:0
- SET ON=$ORDER(^PS(55,DFN,"IV","AIS",WBDT,ON))
- if 'ON
- QUIT
- SET FON=ON_"V"
- SET PSJON(FON)=""
- DO IVVAR
- End DoDot:1
- +12 ;Pending orders
- +13 SET F="^PS(53.1,"
- +14 FOR PST="P","N"
- FOR ON=0:0
- SET ON=$ORDER(^PS(53.1,"AS",PST,DFN,ON))
- if 'ON
- QUIT
- Begin DoDot:1
- +15 SET FON=ON_"P"
- +16 SET X=$PIECE($GET(^PS(53.1,+ON,0)),U,4)
- DO @$SELECT(X="F":"IVVAR",1:"UDVAR")
- End DoDot:1
- +17 ;When a one-time order is found, check against PSJON(FON) array to
- +18 ;make sure no duplicates return on ^TMP.
- +19 IF '+$GET(OTDATE)
- DO NOW^%DTC
- SET X1=$EXTRACT(%,1,12)
- SET X2=-30
- DO C^%DTC
- SET OTDATE=X
- +20 IF OTDATE'["."
- SET OTDATE=OTDATE_".0001"
- +21 if BDT'>OTDATE
- QUIT
- +22 SET F="^PS(55,DFN,5,"
- SET WBDT=OTDATE
- +23 FOR
- SET WBDT=$ORDER(^PS(55,DFN,5,"AU","O",WBDT))
- if 'WBDT
- QUIT
- Begin DoDot:1
- +24 FOR ON=0:0
- SET ON=$ORDER(^PS(55,DFN,5,"AU","O",WBDT,ON))
- if 'ON
- QUIT
- Begin DoDot:2
- +25 SET FON=ON_"U"
- if '$DATA(PSJON(FON))
- DO UDVAR
- End DoDot:2
- End DoDot:1
- +26 SET F="^PS(55,DFN,""IV"","
- SET WBDT=OTDATE
- +27 FOR
- SET WBDT=$ORDER(^PS(55,DFN,"IV","AIS",WBDT))
- if 'WBDT
- QUIT
- Begin DoDot:1
- +28 FOR ON=0:0
- SET ON=$ORDER(^PS(55,DFN,"IV","AIS",WBDT,ON))
- if 'ON
- QUIT
- Begin DoDot:2
- +29 SET X=$PIECE($GET(^PS(55,DFN,"IV",ON,0)),U,9)
- +30 IF X]""
- IF $$ONE(DFN,ON_"V",X,$PIECE(X,"^",2),$PIECE(X,"^",3))="O"
- Begin DoDot:3
- +31 SET FON=ON_"V"
- if '$DATA(PSJON(FON))
- DO IVVAR
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +32 KILL PSJON,PSJBCID
- +33 QUIT
- +34 ;
- UDVAR ;Set ^TMP for Unit dose & Pending orders
- +1 NEW CLINIC
- +2 DO UDPEND
- IF '$$CLINICS($GET(CLINIC))
- QUIT
- +3 DO TMP
- +4 ;Setup Dispense drug for ^TMP
- +5 SET CNT=0
- DO NOW^%DTC
- +6 FOR X=0:0
- SET X=$ORDER(@(F_ON_",1,"_X_")"))
- if 'X
- QUIT
- Begin DoDot:1
- +7 SET PSJDD=@(F_ON_",1,"_X_",0)")
- IF $PIECE(PSJDD,"^",3)]""
- IF $PIECE(PSJDD,"^",3)'>%
- QUIT
- +8 ;*225 Don't allow 0
- +9 IF +$PIECE(PSJDD,"^",2)=0
- SET $PIECE(PSJDD,"^",2)=1
- +10 SET CNT=CNT+1
- +11 SET ^TMP("PSJ",$JOB,PSJINX,700,CNT,0)=+PSJDD_U_$PIECE($GET(^PSDRUG(+PSJDD,0)),U)_U_$SELECT((FON["U")&($PIECE(PSJDD,U,2)=""):1,(FON["U")&($EXTRACT($PIECE(PSJDD,U,2))="."):"0"_$PIECE(PSJDD,U,2),1:$PIECE(PSJDD,U,2))_U_$PIECE(PSJDD,U,3)
- +12 ;add High Risk field to 6th piece of 700 (disp drug) ;*279
- +13 SET $PIECE(^TMP("PSJ",$JOB,PSJINX,700,CNT,0),U,6)=$$GET1^DIQ(50.7,PSJ("OI"),1,"I")
- +14 ;add Prompt For Removal In BCMA fld to 7th ;*315
- +15 SET $PIECE(^TMP("PSJ",$JOB,PSJINX,700,CNT,0),U,7)=+PSJ("MRRFL")
- +16 ;add Haz Handle & Dispose flags at 8 & 9th pieces *364
- +17 SET $PIECE(^TMP("PSJ",$JOB,PSJINX,700,CNT,0),U,8,9)=$PIECE($$HAZ^PSSUTIL(+PSJDD),U,1,2)
- End DoDot:1
- +18 if CNT
- SET ^TMP("PSJ",$JOB,PSJINX,700,0)=CNT
- +19 KILL PSJ,PSJDD
- +20 QUIT
- +21 ;
- IVVAR ;Set variables for IV and pending orders
- +1 NEW ND,X,Y,CLINIC,DDIEN
- +2 IF FON["P"
- DO UDPEND
- if '$$CLINICS(CLINIC)
- QUIT
- SET PSJ("INFRATE")=$PIECE($PIECE($GET(^PS(53.1,ON,8)),U,5),"@")
- +3 IF FON["V"
- Begin DoDot:1
- +4 SET X=$GET(^PS(55,DFN,"IV",ON,0))
- SET CLINIC=$GET(^("DSS"))
- if '$$CLINICS(CLINIC)
- QUIT
- +5 SET PSJ("STARTDT")=$PIECE(X,U,2)
- SET PSJ("STOPDT")=$PIECE(X,U,3)
- +6 SET PSJ("INFRATE")=$PIECE($PIECE(X,U,8),"@")
- SET PSJ("SCHD")=$PIECE(X,U,9)
- +7 SET PSJ("ADM")=$PIECE(X,U,11)
- SET PSJ("AUTO")=$PIECE(X,U,12)
- SET PSJ("STATUS")=$PIECE(X,U,17)
- +8 SET PSJ("IVTYPE")=$PIECE(X,U,4)
- SET PSJ("INSYR")=$PIECE(X,U,5)
- +9 SET PSJ("CPRS")=$PIECE(X,U,21)
- SET PSJ("CHEMO")=$PIECE(X,U,23)
- +10 SET X=$GET(^PS(55,DFN,"IV",ON,.2))
- +11 SET PSJ("DO")=""
- SET PSJ("MR")=$PIECE(X,U,3)
- SET PSJ("PRI")=$PIECE(X,U,4)
- SET PSJ("FLG")=$PIECE(X,U,7)
- SET PSJ("COM")=""
- SET PSJ("SRC")=""
- +12 IF PSJ("FLG")
- Begin DoDot:2
- +13 NEW S1,A,B,C
- +14 SET S1=""
- FOR
- SET S1=$ORDER(^PS(55,DFN,"IV",ON,"A",S1),-1)
- if 'S1
- QUIT
- SET C=$GET(^(S1,0))
- SET A=$PIECE(C,U,2)
- SET B=$PIECE(C,U,4)
- if A="UG"
- QUIT
- Begin DoDot:3
- +15 if A'="G"
- QUIT
- +16 SET PSJ("SRC")=$SELECT(B["FLAGGED BY PHARM":"PHARMACIST",B["FLAGGED BY CPRS":"CPRS",1:"")
- +17 SET PSJ("COM")=$PIECE(B," ",4,99)
- End DoDot:3
- IF PSJ("SRC")]""
- QUIT
- End DoDot:2
- +18 SET PSJ("OI")=+X
- +19 SET X=$GET(^PS(55,DFN,"IV",ON,2))
- +20 SET PSJ("PREV")=$PIECE(X,U,5)
- IF PSJ("PREV")["V"
- IF (+PSJ("PREV")=+ON)
- SET PSJ("PREV")=""
- +21 SET PSJ("FOLLOW")=$PIECE(X,U,6)
- SET PSJ("RFO")=$PIECE(X,U,9)
- IF PSJ("FOLLOW")["V"
- IF (+PSJ("FOLLOW")=+ON)
- SET (PSJ("FOLLOW"),PSJ("RFO"))=""
- +22 SET PSJ("SIOPI")=$SELECT($PIECE($GET(^PS(55,DFN,"IV",+ON,3)),"^",2)&($PIECE($GET(^PS(55,DFN,"IV",+ON,3)),"^")'=""):"!",1:"")_$PIECE($GET(^(3)),"^")
- +23 NEW SCHD
- SET SCHD=PSJ("SCHD")
- +24 SET PSJ("STC")=$$ONE(DFN,ON_"V",SCHD,PSJ("STARTDT"),PSJ("STOPDT"))
- +25 IF PSJ("STC")=""!(PSJ("STC")="C")
- SET PSJ("STC")=$SELECT(SCHD["PRN":"P",1:"C")
- +26 IF PSJ("STC")="C"
- SET PSJ("STC")=$SELECT($$ONCALL(SCHD):"OC",1:"C")
- End DoDot:1
- if '$$CLINICS(CLINIC)
- QUIT
- +27 DO TMP
- +28 SET CNT=0
- +29 FOR X=0:0
- SET X=$ORDER(@(F_ON_",""AD"","_X_")"))
- if 'X
- QUIT
- Begin DoDot:1
- +30 SET ND=$GET(@(F_ON_",""AD"","_X_",0)"))
- SET DN=$GET(^PS(52.6,+ND,0))
- +31 SET CNT=CNT+1
- SET ^TMP("PSJ",$JOB,PSJINX,850,CNT,0)=+ND_U_$PIECE(DN,U)_U_$PIECE(ND,U,2)_U_$PIECE(ND,U,3)
- +32 ;add High Risk field to 6th piece of 850 (additv) ;*279
- +33 SET $PIECE(^TMP("PSJ",$JOB,PSJINX,850,CNT,0),U,6)=$$HRFLG(+ND,"A")
- +34 ;add Haz Handle & Dispose flags at 7 & 8th pieces of additive *364
- +35 SET DDIEN=+$PIECE($GET(^PS(52.6,+ND,0)),U,2)
- +36 SET $PIECE(^TMP("PSJ",$JOB,PSJINX,850,CNT,0),U,7,8)=$PIECE($$HAZ^PSSUTIL(DDIEN),U,1,2)
- End DoDot:1
- +37 if CNT
- SET ^TMP("PSJ",$JOB,PSJINX,850,0)=CNT
- SET CNT=0
- +38 FOR X=0:0
- SET X=$ORDER(@(F_ON_",""SOL"","_X_")"))
- if 'X
- QUIT
- Begin DoDot:1
- +39 SET ND=$GET(@(F_ON_",""SOL"","_X_",0)"))
- SET DN=$GET(^PS(52.7,+ND,0))
- +40 SET CNT=CNT+1
- SET ^TMP("PSJ",$JOB,PSJINX,950,CNT,0)=+ND_U_$PIECE(DN,U)_U_$PIECE(ND,U,2)_U_$PIECE(DN,U,4)
- +41 ;add High Risk field to 6th piece of 950 (sol) ;*279
- +42 SET $PIECE(^TMP("PSJ",$JOB,PSJINX,950,CNT,0),U,6)=$$HRFLG(+ND,"S")
- +43 ;add Haz Handle & Dispose flags at 7 & 8th pieces of additive *364
- +44 SET DDIEN=+$PIECE($GET(^PS(52.7,+ND,0)),U,2)
- +45 SET $PIECE(^TMP("PSJ",$JOB,PSJINX,950,CNT,0),U,7,8)=$PIECE($$HAZ^PSSUTIL(DDIEN),U,1,2)
- End DoDot:1
- +46 if CNT
- SET ^TMP("PSJ",$JOB,PSJINX,950,0)=CNT
- +47 KILL PSJ
- +48 SET X1=0
- +49 FOR
- SET X1=$ORDER(^PS(55,DFN,"IVBCMA",X1))
- if 'X1
- QUIT
- Begin DoDot:1
- +50 SET XX=$GET(^PS(55,DFN,"IVBCMA",X1,0))
- if ON'=$PIECE(XX,"^",2)
- QUIT
- SET PSJBCID=$PIECE(XX,"^")
- SET X2=0
- +51 FOR I=1:1
- SET X2=$ORDER(^PS(55,DFN,"IVBCMA",X1,"AD",X2))
- if 'X2
- QUIT
- Begin DoDot:2
- +52 SET X=^(X2,0)
- SET ^TMP("PSJ",$JOB,PSJINX,800,PSJBCID,I)=+X_"^"_$SELECT($DATA(^PS(52.6,+X,0)):$PIECE(^(0),"^"),1:"*****")_"^"_$PIECE(X,"^",2,99)
- +53 ;add High Risk field to 6th piece of 800 (additv) ;*279
- +54 SET $PIECE(^TMP("PSJ",$JOB,PSJINX,800,PSJBCID,I),U,6)=$$HRFLG(+ND,"A")
- End DoDot:2
- +55 IF I>1
- SET ^TMP("PSJ",$JOB,PSJINX,800,PSJBCID,0)=I-1
- +56 SET X2=0
- +57 FOR I=1:1
- SET X2=$ORDER(^PS(55,DFN,"IVBCMA",X1,"SOL",X2))
- if 'X2
- QUIT
- Begin DoDot:2
- +58 SET X=^(X2,0)
- SET ^TMP("PSJ",$JOB,PSJINX,900,PSJBCID,I)=$PIECE(X,"^")_"^"_$SELECT($DATA(^PS(52.7,$PIECE(X,"^"),0)):$PIECE(^(0),"^"),1:"*****")_"^"_$PIECE(X,"^",2,99)
- +59 ;add High Risk field to 6th piece of 900 (sol) ;*279
- +60 SET $PIECE(^TMP("PSJ",$JOB,PSJINX,900,PSJBCID,I),U,6)=$$HRFLG(+X,"S")
- End DoDot:2
- +61 IF I>1
- SET ^TMP("PSJ",$JOB,PSJINX,900,PSJBCID,0)=I-1
- End DoDot:1
- +62 QUIT
- +63 ;
- UDPEND ;
- +1 SET X=$GET(@(F_ON_",0)"))
- IF $PIECE(F,",")[53.1
- SET CLINIC=$GET(@(F_ON_",""DSS"")"))
- if '$$CLINICS(CLINIC)
- QUIT
- +2 IF $PIECE(F,",")[55
- SET CLINIC=$GET(@(F_ON_",8)"))
- if '$$CLINICS(CLINIC)
- QUIT
- +3 SET PSJ("MR")=$PIECE(X,U,3)
- SET PSJ("SM")=$PIECE(X,U,5)
- SET PSJ("HSM")=$PIECE(X,U,6)
- +4 SET PSJ("ST")=$PIECE(X,U,7)
- SET PSJ("STATUS")=$PIECE(X,U,9)
- +5 SET PSJ("CPRS")=$PIECE(X,U,21)
- SET PSJ("PREV")=$PIECE(X,U,25)
- SET PSJ("FOLLOW")=$PIECE(X,U,26)
- SET PSJ("RFO")=$PIECE(X,U,27)
- +6 if FON["U"
- SET PSJ("NGIVEN")=$PIECE(X,U,22)
- +7 SET X=$GET(@(F_ON_",.2)"))
- +8 SET PSJ("DO")=$PIECE(X,U,2)
- SET PSJ("PRI")=$PIECE(X,U,4)
- SET PSJ("FLG")=$PIECE(X,U,7)
- SET PSJ("COM")=""
- SET PSJ("SRC")=""
- +9 IF PSJ("FLG")
- Begin DoDot:1
- +10 NEW S1,A,B,C
- +11 SET S1=""
- FOR
- SET S1=$ORDER(^PS(55,DFN,5,ON,9,S1),-1)
- if 'S1
- QUIT
- SET C=$GET(^(S1,0))
- SET A=$PIECE(C,U,3)
- SET B=$PIECE(C,U,4)
- if A=7010!(A=7030)
- QUIT
- Begin DoDot:2
- +12 if A'=7000&(A'=7020)
- QUIT
- +13 SET PSJ("SRC")=$SELECT(A=7000:"PHARMACIST",A=7020:"CPRS",1:"")
- +14 SET PSJ("COM")=$GET(@(F_ON_",13)"))
- End DoDot:2
- IF PSJ("SRC")]""
- QUIT
- End DoDot:1
- +15 SET PSJ("OI")=+X
- +16 SET X=$GET(@(F_ON_",2)"))
- +17 SET PSJ("SCHD")=$PIECE(X,U)
- SET PSJ("STARTDT")=$PIECE(X,U,2)
- +18 ;*315 prev stop date for one times
- SET PSJ("PRSTOPDT")=$PIECE(X,U,3)
- +19 SET PSJ("STOPDT")=$PIECE(X,U,4)
- SET PSJ("ADM")=$PIECE(X,U,5)
- +20 ;*315
- SET PSJ("FREQ")=$PIECE(X,U,6)
- +21 ;save Duration & MRR code from 2.1 / convert code 2 = 1 or 3 ;*315
- +22 SET X=$GET(@(F_ON_",2.1)"))
- +23 SET PSJ("DOA")=$PIECE(X,U)
- SET PSJ("RMTM")=$PIECE(X,U,2)
- SET PSJ("MRRFL")=+$PIECE(X,U,4)
- +24 IF PSJ("MRRFL")=2
- SET PSJ("MRRFL")=$SELECT(PSJ("DOA")>0:3,1:1)
- +25 ;if DOA is null, but FREQ exists, then use FREQ as DOA when...
- +26 SET PSJ("DOA")=$SELECT(PSJ("DOA")<1:$GET(PSJ("FREQ")),1:PSJ("DOA"))
- +27 ;
- +28 SET X=$GET(@(F_ON_",4)"))
- +29 SET PSJ("AUTO")=$PIECE(X,U,11)
- +30 ;naked reference on line below refers to full reference created by indirect reference to F_ON, where F may refer to ^PS(53.1 or the IV or UD multiple ^PS(55
- +31 SET PSJ("SIOPI")=$SELECT($PIECE($GET(@(F_ON_",6)")),"^",2)&($PIECE($GET(@(F_ON_",6)")),"^")'=""):"!",1:"")_$$ENSET($PIECE($GET(^(6)),"^"))
- +32 DO SIOPI
- +33 SET PSJ("STC")=PSJ("ST")
- +34 IF PSJ("ST")="R"!(PSJ("ST")="C")
- SET PSJ("STC")=$SELECT(PSJ("SCHD")["PRN":"P",$$ONCALL(PSJ("SCHD")):"OC",$$ONE(DFN,FON,PSJ("SCHD"))="O":"O",1:"C")
- +35 QUIT
- +36 ;
- TMP ;Setup ^TMP that have common fields between IV and U/D
- +1 ;*279
- NEW A,CLNAME,CLNAMPTR
- +2 SET PSJINX=PSJINX+1
- +3 SET PSJ("OINAME")=$$OIDF^PSJLMUT1(+PSJ("OI"))
- IF PSJ("OINAME")["NOT FOUND"
- SET PSJ("OINAME")=""
- +4 SET PSJ("OIDF")=$$GET1^DIQ(50.7,+PSJ("OI"),.02)
- +5 IF PSJ("OINAME")=""
- SET PSJ("OIDF")=""
- +6 SET A=$GET(^PS(51.2,+PSJ("MR"),0))
- SET PSJ("MRABB")=$PIECE(A,U,3)
- SET PSJ("MRNM")=$PIECE(A,U)
- +7 SET ^TMP("PSJ",$JOB,PSJINX,0)=DFN_U_+ON_U_FON_U_PSJ("PREV")_U_PSJ("FOLLOW")_U_$GET(PSJ("IVTYPE"))_U_$GET(PSJ("INSYR"))_U_$GET(PSJ("CHEMO"))_U_PSJ("CPRS")_U_$GET(PSJ("RFO"))
- +8 ;add Clinic name & IEN ptr to TMP 0 node (pieces 11,12) *279
- +9 ;piece 11 determines if order is a CO or IM for BCMA VDL's *279
- +10 ;CL IEN & valid appt date *279
- IF +CLINIC
- IF $$CLINIC(CLINIC)
- Begin DoDot:1
- +11 SET CLNAMPTR=$ORDER(^PS(53.46,"B",+CLINIC,""))
- +12 SET CLNAME=$$GET1^DIQ(53.46,CLNAMPTR_",",.01)
- +13 ;CO ind, CO NAME
- SET $PIECE(^TMP("PSJ",$JOB,PSJINX,0),U,11)=CLNAME
- +14 ;IEN ptr to file 44
- SET $PIECE(^TMP("PSJ",$JOB,PSJINX,0),U,12)=+CLINIC
- End DoDot:1
- +15 ;
- +16 SET ^TMP("PSJ",$JOB,PSJINX,1)=PSJ("MRABB")_U_PSJ("STC")_U_$GET(PSJ("SCHD"))_U_PSJ("STARTDT")_U_PSJ("STOPDT")_U_PSJ("ADM")_U_PSJ("STATUS")_U_$GET(PSJ("NGIVEN"))_U_$GET(PSJ("ST"))_U_$GET(PSJ("AUTO"))
- +17 ;add DOA, Remove Times, MRR code, & prev stop DT to pieces 12-15 *315
- +18 SET $PIECE(^TMP("PSJ",$JOB,PSJINX,1),U,12)=$GET(PSJ("DOA"))
- +19 SET $PIECE(^TMP("PSJ",$JOB,PSJINX,1),U,13)=$GET(PSJ("RMTM"))
- +20 SET $PIECE(^TMP("PSJ",$JOB,PSJINX,1),U,14)=$GET(PSJ("MRRFL"))
- +21 SET $PIECE(^TMP("PSJ",$JOB,PSJINX,1),U,15)=$GET(PSJ("PRSTOPDT"))
- +22 ;
- +23 ;*267 append file 51.2 ien
- SET ^TMP("PSJ",$JOB,PSJINX,1,0)=$PIECE(A,U,8)_U_PSJ("MRNM")_U_$PIECE(A,U,9)_U_+PSJ("MR")
- +24 SET ^TMP("PSJ",$JOB,PSJINX,2)=PSJ("DO")_U_$PIECE($GET(PSJ("INFRATE")),"@")_U_$GET(PSJ("SM"))_U_$GET(PSJ("HSM"))
- +25 SET ^TMP("PSJ",$JOB,PSJINX,3)=PSJ("OI")_U_PSJ("OINAME")_U_PSJ("OIDF")
- +26 SET ^TMP("PSJ",$JOB,PSJINX,4)=PSJ("SIOPI")
- +27 SET A=$$SNDTSTA^PSJHL4A(PSJ("PRI"),PSJ("SCHD"))
- +28 SET ^TMP("PSJ",$JOB,PSJINX,5)=$SELECT(A=1:0,1:1)_U_PSJ("FLG")_U_PSJ("SRC")_U_PSJ("COM")
- +29 QUIT
- +30 ;
- SIOPI ; Use provider comments if order is pending and there is no SI
- +1 NEW X,Y,Z
- +2 IF FON["P"
- IF (PSJ("SIOPI")="")
- IF $ORDER(^PS(53.1,+ON,12,0))
- Begin DoDot:1
- +3 FOR X=0:0
- SET X=$ORDER(^PS(53.1,+ON,12,X))
- if 'X
- QUIT
- SET Z=$GET(^(X,0))
- Begin DoDot:2
- +4 SET Y=$LENGTH(PSJ("SIOPI"))
- +5 if Y+$LENGTH(Z)'>179
- SET PSJ("SIOPI")=PSJ("SIOPI")_Z_""
- End DoDot:2
- +6 IF Y+$LENGTH(Z)>179
- SET PSJ("SIOPI")="SEE PROVIDER COMMENTS"
- End DoDot:1
- +7 QUIT
- +8 ;
- ENSET(X) ; expands SPECIAL INSTRUCTIONS field contained in X into Y
- +1 NEW X1,X2,Y
- SET Y=""
- +2 FOR X1=1:1:$LENGTH(X," ")
- SET X2=$PIECE(X," ",X1)
- IF X2]""
- SET Y=Y_$SELECT($LENGTH(X2)>30:X2,'$DATA(^PS(51,+$ORDER(^PS(51,"B",X2,0)),0)):X2,$PIECE(^(0),"^",2)]""&$PIECE(^(0),"^",4):$PIECE(^(0),"^",2),1:X2)_" "
- +3 SET Y=$EXTRACT(Y,1,$LENGTH(Y)-1)
- +4 QUIT Y
- +5 ;
- ONE(DFN,ORD,SCH,START,STOP) ;Determine if order is one-time, and return schedule type
- +1 ; Input: DFN - patient's IEN
- +2 ; ORD - order number
- +3 ; SCH - schedule text (required)
- +4 ; START - order start date (optional)
- +5 ; STOP - order stop date (optional)
- +6 NEW X,ONEFRQ,TYP,T
- +7 IF $GET(PSJ("PREV"))
- IF $GET(PSJ("FOLLOW"))
- IF +PSJ("PREV")=+PSJ("FOLLOW")
- SET (PSJ("PREV"),PSJ("FOLLOW"))=""
- +8 ; PSJ*5*190 One-Time PRN
- +9 IF $GET(SCH)=""
- IF $GET(DFN)
- IF $GET(ORD)
- Begin DoDot:1
- +10 IF ORD["U"
- SET SCH=$PIECE($GET(^PS(55,DFN,5,+ORD,2)),"^")
- +11 IF ORD["V"
- SET SCH=$PIECE($GET(^PS(55,DFN,"IV",+ORD,0)),"^",9)
- End DoDot:1
- +12 IF $GET(SCH)]""
- IF $$OTPRN^PSJBCMA3(SCH)="O"
- QUIT "O"
- +13 IF $GET(DFN)]""
- IF $GET(ORD)]""
- IF ORD["U"
- IF $PIECE(^PS(55,DFN,5,+ORD,0),"^",7)'="R"
- QUIT $PIECE(^PS(55,DFN,5,+ORD,0),"^",7)
- +14 IF $GET(SCH)=""
- QUIT ""
- +15 ; PSJ*5*113 Determine schedule type from ^PS(51.1, not from schedule name.
- +16 IF $DATA(^PS(51.1,"AC","PSJ",SCH))
- SET X=$ORDER(^(SCH,""))
- SET X=$PIECE(^PS(51.1,X,0),"^",5)
- QUIT $SELECT(X="D":"C",1:X)
- +17 IF $GET(START)]""
- IF $GET(STOP)]""
- IF START=STOP
- QUIT "O"
- +18 IF $$DAY(SCH)
- QUIT "C"
- +19 QUIT ""
- +20 ;
- CLINIC(CL) ; is a valid appointment date present? 1=yes 0 =no
- +1 IF $PIECE(CL,"^",2)?7N!($PIECE(CL,"^",2)?7N1".".N)
- QUIT 1
- +2 QUIT 0
- +3 ;
- CLINICS(CL,IGNOSND) ;IM & CO order tests *70
- +1 ; Send IM orders always. Send Clinic orders as CO order, if it
- +2 ; meets below conditions, else send the order over as a IM order.
- +3 ;
- +4 ; If CPRS sends the Clinic IEN and the appointment date when the
- +5 ; order is signed in CPRS, then this is a Clinic order and can be
- +6 ; sent to BCMA as a CO order, if it passes the 53.46 test as well.
- +7 ;
- +8 ; IGNOSND = Flag indicating the SEND TO BCMA parameter should be ignored.
- +9 ; PSJHYBR = Hybrid order - contains reference to CLINIC, but no appointment date time
- +10 ; Function Return values: 1 = Send order to BCMA
- +11 ; 0 = Do Not send order to BCMA
- +12 ; * Orders with Clinic but no Appt should only be sent if patient is admitted or SEND TO BCMA flag set
- +13 IF '$GET(CL)!$GET(IGNOSND)
- QUIT 1
- +14 NEW PSJVAIN4,X,PSJCNT,PSJSTRT,PSJSTOP,VAIP
- SET PSJVAIN4=1
- IF $GET(DFN)
- Begin DoDot:1
- +15 ;add code check for historical data when running BCMA
- NEW VAIN,PSGP
- SET PSGP=DFN
- DO INP^VADPT
- IF '$GET(VAIN(4))
- SET PSJVAIN4=0
- IF $GET(PSBRPT(".1"))'=""
- Begin DoDot:2
- +16 SET PSJSTOP=$PIECE(PSBRPT(".1"),U,8)
- SET PSJSTRT=$PIECE(PSBRPT(".1"),U,6)
- if 'PSJSTOP!'(PSJSTRT)
- QUIT
- +17 ;check to see if patient was admitted during time frame of report
- SET PSJCNT=PSJSTRT
- FOR
- if PSJCNT>PSJSTOP
- QUIT
- SET VAIP("D")=PSJCNT
- DO IN5^VADPT
- if +VAIP("3")
- SET PSJVAIN4=1
- SET PSJCNT=$$FMADD^XLFDT(PSJCNT,1)
- if $GET(PSJVAIN4)
- QUIT
- End DoDot:2
- +18 ;return patient data for Edit med log option if patient was admitted when med log entry was recorded
- IF 'PSJVAIN4
- IF $GET(PSBREC(2))
- IF $GET(PSBREC(0))="ADMLKUP"
- SET VAIP("D")=PSBREC(2)
- DO IN5^VADPT
- if +VAIP("3")
- SET PSJVAIN4=1
- +19 ;*318
- IF 'PSJVAIN4
- IF $GET(PSBPRNDT)
- SET VAIP("D")=$PIECE(PSBSTRT,".")
- DO IN5^VADPT
- if +VAIP("3")
- SET PSJVAIN4=1
- +20 ;*318
- IF 'PSJVAIN4
- IF ($GET(PSBTYPE)="PM")
- IF $GET(PSJ("STARTDT"))
- SET VAIP("D")=$PIECE(PSJ("STARTDT"),".")
- DO IN5^VADPT
- if +VAIP("3")
- SET PSJVAIN4=1
- End DoDot:1
- +21 ;no valid appt date
- IF $GET(PSJVAIN4)
- if '$$CLINIC(CL)
- QUIT 1
- +22 NEW A
- +23 SET A=$ORDER(^PS(53.46,"B",+CL,""))
- if 'A
- QUIT 0
- +24 if '$DATA(^PS(53.46,"B",+CL))
- QUIT 0
- +25 ;send to bcma? flag
- QUIT $PIECE(^PS(53.46,A,0),"^",4)
- +26 ;
- DAY(SCH) ;determine if this is a 'day of the week' schedule
- +1 IF $GET(SCH)=""
- QUIT 0
- +2 NEW D,DAY,DAYS,I,X
- +3 SET DAYS="SUNDAY,MONDAY,TUESDAY,WEDNESDAY,THURSDAY,FRIDAY,SATURDAY"
- +4 FOR I=1:1
- SET D=$PIECE(SCH,"-",I)
- if D=""
- QUIT
- Begin DoDot:1
- +5 SET X=0
- FOR J=1:1:7
- SET DAY=$PIECE(DAYS,",",J)
- Begin DoDot:2
- +6 IF D=$EXTRACT(DAY,1,$LENGTH(D))
- SET X=1
- End DoDot:2
- if X=1
- QUIT
- End DoDot:1
- if X=0
- QUIT
- +7 QUIT X
- +8 ;
- ONCALL(SCHD) ; Check if a schedule is type On Call (all "APPSJ" schedules with a given name must have the same schedule type)
- +1 NEW NXT,SCHARR,OCCHK
- +2 SET OCCHK=0
- +3 if $GET(SCHD)=""
- QUIT OCCHK
- +4 if '$DATA(^PS(51.1,"APPSJ",SCHD))
- QUIT OCCHK
- +5 SET NXT=0
- FOR
- SET NXT=$ORDER(^PS(51.1,"APPSJ",SCHD,NXT))
- if 'NXT
- QUIT
- SET TYP=$PIECE($GET(^PS(51.1,+NXT,0)),"^",5)
- if TYP]""
- SET SCHARR(TYP)=""
- +6 IF '$DATA(SCHARR("OC"))
- SET OCCHK=0
- QUIT OCCHK
- +7 IF $ORDER(SCHARR("OC"))]""!($ORDER(SCHARR("OC"),-1)]"")
- SET OCCHK=0
- QUIT OCCHK
- +8 IF $DATA(SCHARR("OC"))
- SET OCCHK=1
- +9 QUIT OCCHK
- +10 ;
- HRFLG(IEN,ADDSOL) ;Get High Risk flag for this Orderable Item
- +1 NEW OIIEN
- +2 if ADDSOL="A"
- SET OIIEN=+$$GET1^DIQ(52.6,IEN,15,"I")
- +3 if ADDSOL="S"
- SET OIIEN=+$$GET1^DIQ(52.7,IEN,9,"I")
- +4 QUIT +$$GET1^DIQ(50.7,OIIEN,1,"I")