- PSJBCMA1 ;BIR/MV-RETURN INFORMATION FOR AN ORDER ; 5/4/16 1:09pm
- ;;5.0;INPATIENT MEDICATIONS ;**32,41,46,57,63,66,56,58,81,91,104,186,159,173,253,267,279,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.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 ^DIC is supported by DBIA 10006.
- ; Reference to ^DIQ is supported by DBIA 2056.
- ; Usage of this routine by BCMA is supported by DBIA 289.
- ;
- ;*267 - add Standard Routine Name from file 51.2 field 10
- ;*279 - return High Risk field form file #50 for Unit dose and IV's
- ; for the dispensed drug/additive/solution
- ; - add Clinic name, IEN to pieces 11, 12 of TMP("PSJ1",$J,0)
- ;*315 - add Duration of Administration time for MRR (on/off) meds to 4 node
- ; also 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,ON,PSJTMP,PSJIGS2B,PSJEXIST) ; return detail data for Inpatient Meds.
- NEW F,A
- S PSJTMP=$S($G(PSJTMP)=1:"PSJ1",1:"PSJ")
- I $G(ON)["U" S F="^PS(55,+$G(DFN),5,+ON" D:$D(@(F_")")) UDVAR
- I $G(ON)["V" S F="^PS(55,+$G(DFN),""IV"",+ON" D:$D(@(F_")")) IVVAR
- I $G(ON)["P" S F="^PS(53.1,+ON",X=$P($G(^PS(53.1,+ON,0)),U,4) D:$D(@(F_")")) @$S(X="F":"IVVAR",1:"UDVAR")
- I '$D(^TMP(PSJTMP,$J,0)) S ^(0)=-1
- Q
- ;
- UDVAR ;* Set ^TMP for Unit dose & Pending orders
- N CNT,CLINIC
- D UDPEND I '$$CLINICS^PSJBCMA($G(CLINIC),$G(PSJIGS2B)) Q ;*279
- D TMP
- ;* Setup Dispense drug for ^TMP
- S CNT=0 D NOW^%DTC
- F X=0:0 S X=$O(@(F_",1,"_X_")")) Q:'X D
- . S PSJDD=@(F_",1,"_X_",0)") I $P(PSJDD,"^",3)]"",$P(PSJDD,"^",3)'>% Q
- . S CNT=CNT+1
- . S ^TMP(PSJTMP,$J,700,CNT,0)=+PSJDD_U_$P($G(^PSDRUG(+PSJDD,0)),U)_U_$S((ON["U")&($P(PSJDD,U,2)=""):1,(ON["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(PSJTMP,$J,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(PSJTMP,$J,700,CNT,0),U,7)=+PSJ("MRRFL")
- . ;add Haz Handle & Dispose flags at 8 & 9th pieces *364
- . S $P(^TMP(PSJTMP,$J,700,CNT,0),U,8,9)=$P($$HAZ^PSSUTIL(+PSJDD),U,1,2)
- S:CNT ^TMP(PSJTMP,$J,700,0)=CNT
- K PSJ,PSJDD,PSJDN
- Q
- ;
- IVVAR ;* Set variables for IV and pending orders
- N CNT,DN,ND,X,Y,CLINIC,OIIEN
- N DDIEN ;*364
- ;don't send orders to BCMA that fail the Clinic test ;*279
- ; Pending's
- I ON["P" D I '$$CLINICS^PSJBCMA($G(CLINIC),$G(PSJIGS2B)) Q ;*279
- . D UDPEND ;*279
- . S PSJ("INFRATE")=$P($P($G(^PS(53.1,ON,8)),U,5),"@") ;*279
- ; IV's
- I ON["V" D I '$$CLINICS^PSJBCMA($G(CLINIC),$G(PSJIGS2B)) Q ;*279
- . S X=$G(^PS(55,DFN,"IV",+ON,0))
- . S PSJ("STARTDT")=$P(X,U,2),PSJ("STOPDT")=$P(X,U,3)
- . S PSJ("PROVIDER")=$P(X,U,6)
- . S PSJEXIST=$S((PSJ("PROVIDER")'=""):1,1:0)
- . 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("FREQ")=$P(X,U,15),PSJ("IVTYPE")=$P(X,U,4)
- . S PSJ("INSYR")=$P(X,U,5),PSJ("CPRS")=$P(X,U,21),PSJ("CHEMO")=$P(X,U,23)
- . S X=$G(^PS(55,DFN,"IV",+ON,.2))
- . S PSJ("OI")=$P(X,U),PSJ("DO")="",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("MR")=$P(X,U,3)
- . S X=$G(^PS(55,DFN,"IV",+ON,4))
- . S PSJ("NURSE")=$P(X,U)
- . S PSJ("PHARM")=$P(X,U,4)
- . S X=$G(^PS(55,DFN,"IV",+ON,2))
- . S PSJ("LDT")=$P(X,U)
- . S PSJ("PREV")=$P(X,U,5),PSJ("FOLLOW")=$P(X,U,6)
- . 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") ; SCHD var required to shorten $Select
- . S PSJ("STC")=$$ONE^PSJBCMA(DFN,ON,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^PSJBCMA(PSJ("SCHD")):"OC",1:"C")
- . S PSJ("NURSE")=$P($G(^PS(55,DFN,"IV",+ON,4)),U)
- . S CLINIC=$G(^PS(55,DFN,"IV",+ON,"DSS")) ;*279
- ;
- D TMP
- S X=$P($G(^PS(55,DFN,"IV",+ON,1)),U) S:X]"" ^TMP(PSJTMP,$J,6)=X
- S CNT=0
- F X=0:0 S X=$O(@(F_",""AD"","_X_")")) Q:'X D
- . S ND=$G(@(F_",""AD"","_X_",0)")),DN=$G(^PS(52.6,+ND,0)) ;,AOINAME=$$OIDF^PSJLMUT1(+$P(DN,U,11)) I AOINAME["NOTFOUND" S AOINAME=""
- . S CNT=CNT+1,^TMP(PSJTMP,$J,850,CNT,0)=+ND_U_$P(DN,U)_U_$P(ND,U,2)_U_$P(ND,U,3) ;_U_U_$P(DN,U,11)_U_AOINAME_U_AOIDF
- . ;add High Risk field to 6th piece of 850 (additive) ;*279
- . S $P(^TMP(PSJTMP,$J,850,CNT,0),U,6)=$$HRFLG^PSJBCMA(+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(PSJTMP,$J,850,CNT,0),U,7,8)=$P($$HAZ^PSSUTIL(DDIEN),U,1,2)
- ;
- S:CNT ^TMP(PSJTMP,$J,850,0)=CNT,CNT=0
- F X=0:0 S X=$O(@(F_",""SOL"","_X_")")) Q:'X D
- . S ND=$G(@(F_",""SOL"","_X_",0)")),DN=$G(^PS(52.7,+ND,0)) ;,SOINAME=$$OIDF^PSJLMUT1(+$P(DN,U,11)) I SOINAME["NOTFOUND" S SOINAME=""
- . S CNT=CNT+1,^TMP(PSJTMP,$J,950,CNT,0)=+ND_U_$P(DN,U)_U_$P(ND,U,2)_U_$P(DN,U,4) ;_U_U_$P(DN,U,11)_U_SOINAME_U_SOIDF
- . ;add High Risk field to 6th piece of 950 (solution) ;*279
- . S $P(^TMP(PSJTMP,$J,950,CNT,0),U,6)=$$HRFLG^PSJBCMA(+ND,"S")
- . ;add Haz Handle & Dispose flags at 7 & 8th pieces of solution *364
- . S DDIEN=+$P($G(^PS(52.7,+ND,0)),U,2)
- . S $P(^TMP(PSJTMP,$J,950,CNT,0),U,7,8)=$P($$HAZ^PSSUTIL(DDIEN),U,1,2)
- S:CNT ^TMP(PSJTMP,$J,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:$P(XX,"^",2)'=+ON 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(PSJTMP,$J,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 (additive) ;*279
- .. S $P(^TMP(PSJTMP,$J,800,PSJBCID,I),U,6)=$$HRFLG^PSJBCMA(+X,"A")
- . I I>1 S ^TMP(PSJTMP,$J,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(PSJTMP,$J,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 (solution) ;*279
- .. S $P(^TMP(PSJTMP,$J,900,PSJBCID,I),U,6)=$$HRFLG^PSJBCMA(+X,"S")
- . I I>1 S ^TMP(PSJTMP,$J,900,PSJBCID,0)=I-1
- . S ^TMP(PSJTMP,$J,1000,PSJBCID)=$P(XX,"^",6)_"^"_$P(XX,"^",8)_"^"_$P(XX,"^",7)
- Q
- ;
- UDPEND ;
- S X=$G(@(F_",0)"))
- ;get clinic node per F = global file ;*279
- I $P(F,",")[53.1 S CLINIC=$G(@(F_",""DSS"")"))
- I $P(F,",")[55 S CLINIC=$G(@(F_",8)"))
- ;
- S PSJ("PROVIDER")=$P(X,U,2)
- S PSJEXIST=$S((PSJ("PROVIDER")'=""):1,1:0)
- 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("LDT")=$P(X,U,16)
- S:ON["U" PSJ("NGIVEN")=$P(X,U,22)
- S PSJ("SMYN")=$S(+PSJ("SM"):"YES",1:"NO")
- S PSJ("HSMYN")=$S(+PSJ("HSM"):"YES",1:"NO")
- S PSJ("CPRS")=$P(X,U,21),PSJ("PREV")=$P(X,U,25),PSJ("FOLLOW")=$P(X,U,26)
- S X=$G(@(F_",.2)"))
- S PSJ("OI")=$P(X,U),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_",13)"))
- S X=$G(@(F_",2)"))
- S PSJ("SCHD")=$P(X,U),PSJ("STARTDT")=$P(X,U,2)
- S PSJ("STC")=PSJ("ST")
- I PSJ("ST")="R"!(PSJ("ST")="C") S PSJ("STC")=$S(PSJ("SCHD")["PRN":"P",$$ONCALL^PSJBCMA(PSJ("SCHD")):"OC",$$ONE^PSJBCMA(DFN,ON,PSJ("SCHD"))="O":"O",1:"C")
- I PSJ("STC")="O" S PSJ("ST")="O"
- 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)
- ;save Duration, remove times, & MRR code / convert code 2 = 1 or 3 ;*315
- S X=$G(@(F_",2.1)")),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, then use FREQ for DOA If below true:
- S PSJ("DOA")=$S(PSJ("DOA")<1:$G(PSJ("FREQ")),1:PSJ("DOA"))
- ;
- S X=$G(@(F_",4)"))
- S PSJ("NURSE")=$P(X,U),PSJ("AUTO")=$P(X,U,11)
- S:ON["U" PSJ("PHARM")=+$P(X,U,3)
- ; the naked reference on the line below refers to the full reference created by indirect reference to F, where F may refer to ^PS(53.1 or the IV or UD multiple ^PS(55
- S PSJ("SIOPI")=$S($P($G(@(F_",6)")),"^",2)&($P($G(@(F_",6)")),"^")'=""):"!",1:"")_$$ENSET^PSJBCMA($P($G(^(6)),"^"))
- NEW FON S FON=ON D SIOPI^PSJBCMA
- Q
- ;
- TMP ;* Setup ^TMP that have common fields between IV and U/D
- N CLNAME,CLNAMPTR
- D NAME(PSJ("PROVIDER"),.PSJNAME,"","")
- S PSJ("PRONAME")=PSJNAME K PSJNAME
- I $D(PSJ("PHARM")) D
- . D NAME(PSJ("PHARM"),.PSJNAME,.PSJINIT,.PSJPIEN)
- . S PSJ("PHARM")=PSJPIEN,PSJ("PNAME")=PSJNAME,PSJ("PINIT")=PSJINIT K PSJNAME,PSJINIT,PSJPIEN
- I +PSJ("NURSE") D
- . D NAME(PSJ("NURSE"),.PSJNAME,.PSJINIT,"")
- . S PSJ("NNAME")=PSJNAME,PSJ("NINIT")=PSJINIT K PSJNAME,PSJINIT
- S A=$G(^PS(51.2,+PSJ("MR"),0)),PSJ("MRNM")=$P(A,U),PSJ("MRABB")=$P(A,U,3),PSJ("MRPIJ")=$P(A,U,8),PSJ("MRIVP")=$P(A,U,9)
- S PSJ("MRSTDRNM")=$$GET1^DIQ(51.2,+PSJ("MR"),10) ;*267 Std Rte name
- 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 PSJ("LDTN")=$$DATE(PSJ("LDT"))
- S PSJ("STARTDTN")=$$DATE(PSJ("STARTDT"))
- S PSJ("STOPDTN")=$$DATE(PSJ("STOPDT"))
- S X=$S(ON["V":PSJ("STC"),1:PSJ("ST"))
- S PSJ("STNAME")=$S(X="C":"CONTINUOUS",X="O":"ONE TIME",X="P":"PRN",X="R":"FILL ON REQUEST",X="OC":"ON CALL",1:"NOT FOUND")
- ;
- S ^TMP(PSJTMP,$J,0)=DFN_U_+ON_U_ON_U_PSJ("PREV")_U_PSJ("FOLLOW")_U_$G(PSJ("IVTYPE"))_U_$G(PSJ("INSYR"))_U_$G(PSJ("CHEMO"))_U_PSJ("CPRS")
- ;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^PSJBCMA(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(PSJTMP,$J,0),U,11)=CLNAME ;CO ind, CO NAME
- . S $P(^TMP(PSJTMP,$J,0),U,12)=+CLINIC ;IEN ptr to file 44
- ;
- S ^TMP(PSJTMP,$J,1)=PSJ("PROVIDER")_U_PSJ("PRONAME")_U_PSJ("MR")_U_PSJ("MRABB")_U_$G(PSJ("SM"))_U_$G(PSJ("SMYN"))_U_$G(PSJ("HSM"))_U_$G(PSJ("HSMYN"))_U_$G(PSJ("NGIVEN"))_U_PSJ("STATUS")
- S ^TMP(PSJTMP,$J,1)=^TMP(PSJTMP,$J,1)_U_$$STATUS(ON,PSJ("STATUS"))_U_$G(PSJ("AUTO"))_U_$G(PSJ("MRNM"))_U_PSJ("MRSTDRNM") ;*267 Std Rte nam
- S ^TMP(PSJTMP,$J,1,0)=PSJ("MRPIJ")_U_$G(PSJ("MRIVP"))
- S ^TMP(PSJTMP,$J,2)=PSJ("OI")_U_PSJ("OINAME")_U_PSJ("DO")_U_$P($G(PSJ("INFRATE")),"@")_U_$G(PSJ("SCHD"))_U_PSJ("OIDF")
- S ^TMP(PSJTMP,$J,3)=PSJ("SIOPI")
- S ^TMP(PSJTMP,$J,4)=PSJ("STC")_U_$G(PSJ("STNAME"))_U_PSJ("LDT")_U_PSJ("LDTN")_U_PSJ("STARTDT")_U_PSJ("STARTDTN")_U_PSJ("STOPDT")_U_PSJ("STOPDTN")_U_$$ADMIN(PSJ("ADM"))_U_$G(PSJ("ST"))_U_$G(PSJ("FREQ"))
- ;add DOA, Remove Times, MRR code, & prev stop DT to pieces 12-15 *315
- S $P(^TMP(PSJTMP,$J,4),U,12)=$G(PSJ("DOA"))
- S $P(^TMP(PSJTMP,$J,4),U,13)=$G(PSJ("RMTM"))
- S $P(^TMP(PSJTMP,$J,4),U,14)=$G(PSJ("MRRFL"))
- S $P(^TMP(PSJTMP,$J,4),U,15)=$G(PSJ("PRSTOPDT"))
- S ^TMP(PSJTMP,$J,5)=$G(PSJ("NURSE"))_U_$G(PSJ("NNAME"))_U_$G(PSJ("NINIT"))_U_$G(PSJ("PHARM"))_U_$G(PSJ("PNAME"))_U_$G(PSJ("PINIT"))
- S A=$$SNDTSTA^PSJHL4A(PSJ("PRI"),PSJ("SCHD"))
- S ^TMP(PSJTMP,$J,7)=$S(A=1:0,1:1)_U_PSJ("FLG")_U_PSJ("SRC")_U_PSJ("COM")
- Q
- ;
- NAME(X,NAME,INIT,IEN) ;Lookup in ^VA(200.
- ;X = IEN or Name in ^VA(200
- ;IEN = Return IEN in ^VA(200
- ;NAME = Return the name in 200
- ;INIT = Return the initial
- NEW DIC,Y
- S DIC="^VA(200,",DIC(0)="NZ" D ^DIC
- S IEN=+Y
- S NAME=$G(Y(0,0))
- S INIT=$P($G(Y(0)),U,2)
- Q
- ;
- DATE(Y) ; FM internal date/time to user readable, 4 digit year
- ; Y - date in FileMan internal format
- I $G(Y) S Y=Y_$E(".",Y'[".")_"0000" Q $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700)_" "_$E(Y,9,10)_":"_$E(Y,11,12)
- Q "********"
- ;
- STATUS(ON,X) ;
- ; ON = IEN_"I/U/P"
- ; X = STATUS
- I X="P" Q $S(ON["P":"PENDING",ON["V":"PURGE",1:"NOT FOUND")
- Q $S(X="A":"ACTIVE",X="D":"DISCONTINUED",X="E":"EXPIRED",X="H":"HOLD",X="R":"RENEWED",X="RE":"REINSTATED",X="N":"NON-VERFIED",X="DE":"DISCONTINUED (EDIT)",X="O":"ON CALL",1:"NOT FOUND")
- ;
- ADMIN(X) ; N
- NEW Y,PSJADM,PSJX S PSJADM=""
- I X="" Q ""
- F Y=1:1:$L(X,"-") S PSJX=$E($P(X,"-",Y)_"0000",1,4) D
- . S PSJADM=PSJADM_$S(PSJADM]"":"-",1:"")_PSJX
- Q PSJADM
- ;
- MVOPIAL(DFN,PSJI1,PSJI2) ; Move Other Print Info Activity log entries from NV order to Active order, during Verification
- Q:'$G(DFN)!'$G(PSJI1)!'$G(PSJI2) Q:'$D(^PS(55,DFN,"IV",+PSJI2,0))
- I PSJI1["P",PSJI2["V" N AL,ALND,PNDND0,TXTLN,TXTCNT S AL=0,ALND=0 F S AL=$O(^PS(53.1,+PSJI1,"A",AL)) Q:'AL I ^(AL,0)["OTHER PRINT INFO" D
- .Q:'$D(^PS(53.1,+PSJI1,"A",AL,1,0)) ; Don't retain activity log entry if no text
- .S PNDND0=$G(^PS(53.1,+PSJI1,"A",AL,0)) N USER,NAME S USER=$P(PNDND0,"^",2) D NAME^PSGSICH(USER,.NAME)
- .N AL2 S AL2=$O(^PS(55,DFN,"IV",+PSJI2,"A"," "),-1)+1 N OPILIN S OPILIN=+$O(^PS(53.1,+PSJI1,"A",AL,1,""),-1)
- .S ^PS(55,DFN,"IV",+PSJI2,"A",AL2,0)=AL_"^E^"_NAME_"^^"_$P(PNDND0,"^")_"^"_USER,^PS(55,DFN,"IV",+PSJI2,"A",AL2,1,0)="^55.151^1^1"
- .S ^PS(55,DFN,"IV",+PSJI2,"A",AL2,1,1,0)="OTHER PRINT INFO"
- .S TXTLN=0 F TXTCNT=0:1 S TXTLN=$O(^PS(53.1,+PSJI1,"A",AL,1,TXTLN)) Q:'TXTLN D
- ..S ^PS(55,DFN,"IV",+PSJI2,"A",AL2,2,TXTLN,0)=^PS(53.1,+PSJI1,"A",AL,1,TXTLN,0)
- .I $G(TXTCNT) S ^PS(55,DFN,"IV",+PSJI2,"A",AL2,2,0)="^^"_+$G(TXTCNT)_"^"_$G(TXTCNT)_"^"_+$G(^PS(53.1,+PSJI1,"A",AL,0)) D
- ..S ^PS(55,DFN,"IV",+PSJI2,"A",AL2,1,1,0)="OTHER PRINT INFO"
- Q
- ;
- OPIWARN(AFTER) ; Warn user about OPI not printing on IV labels
- N DIR S DIR=""
- N PSJSTARZ S $P(PSJSTARZ,"*",69)="*" W !!?5,$E(PSJSTARZ,1,29)," WARNING ",$E(PSJSTARZ,1,31)
- W !?5,"**",$S(AFTER:" ",1:" If "),"OTHER PRINT INFO exceeds 60 characters"_$S(AFTER:"! **",1:", **")
- W !?5,"** 'Instructions too long. See Order View or BCMA for full text.' **"
- W !?5,"** will print on the IV label instead of the full text. **",!?5,PSJSTARZ
- W !! D PAUSE^VALM1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJBCMA1 15196 printed Jan 18, 2025@03:07:28 Page 2
- PSJBCMA1 ;BIR/MV-RETURN INFORMATION FOR AN ORDER ; 5/4/16 1:09pm
- +1 ;;5.0;INPATIENT MEDICATIONS ;**32,41,46,57,63,66,56,58,81,91,104,186,159,173,253,267,279,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.2 is supported by DBIA 2178.
- +5 ; Reference to ^PS(52.6 is supported by DBIA 1231.
- +6 ; Reference to ^PS(52.7 is supported by DBIA 2173.
- +7 ; Reference to ^PS(55 is supported by DBIA 2191.
- +8 ; Reference to ^PSDRUG is supported by DBIA 2192.
- +9 ; Reference to ^DIC is supported by DBIA 10006.
- +10 ; Reference to ^DIQ is supported by DBIA 2056.
- +11 ; Usage of this routine by BCMA is supported by DBIA 289.
- +12 ;
- +13 ;*267 - add Standard Routine Name from file 51.2 field 10
- +14 ;*279 - return High Risk field form file #50 for Unit dose and IV's
- +15 ; for the dispensed drug/additive/solution
- +16 ; - add Clinic name, IEN to pieces 11, 12 of TMP("PSJ1",$J,0)
- +17 ;*315 - add Duration of Administration time for MRR (on/off) meds to 4 node
- +18 ; also add BCMA removal flag to 7th piece of 700 node
- +19 ;*364 - add Hazardous Handle & Dispose flags to Unit Dose and IV drug TMP globals
- +20 ;
- EN(DFN,ON,PSJTMP,PSJIGS2B,PSJEXIST) ; return detail data for Inpatient Meds.
- +1 NEW F,A
- +2 SET PSJTMP=$SELECT($GET(PSJTMP)=1:"PSJ1",1:"PSJ")
- +3 IF $GET(ON)["U"
- SET F="^PS(55,+$G(DFN),5,+ON"
- if $DATA(@(F_")"))
- DO UDVAR
- +4 IF $GET(ON)["V"
- SET F="^PS(55,+$G(DFN),""IV"",+ON"
- if $DATA(@(F_")"))
- DO IVVAR
- +5 IF $GET(ON)["P"
- SET F="^PS(53.1,+ON"
- SET X=$PIECE($GET(^PS(53.1,+ON,0)),U,4)
- if $DATA(@(F_")"))
- DO @$SELECT(X="F":"IVVAR",1:"UDVAR")
- +6 IF '$DATA(^TMP(PSJTMP,$JOB,0))
- SET ^(0)=-1
- +7 QUIT
- +8 ;
- UDVAR ;* Set ^TMP for Unit dose & Pending orders
- +1 NEW CNT,CLINIC
- +2 ;*279
- DO UDPEND
- IF '$$CLINICS^PSJBCMA($GET(CLINIC),$GET(PSJIGS2B))
- 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_",1,"_X_")"))
- if 'X
- QUIT
- Begin DoDot:1
- +7 SET PSJDD=@(F_",1,"_X_",0)")
- IF $PIECE(PSJDD,"^",3)]""
- IF $PIECE(PSJDD,"^",3)'>%
- QUIT
- +8 SET CNT=CNT+1
- +9 SET ^TMP(PSJTMP,$JOB,700,CNT,0)=+PSJDD_U_$PIECE($GET(^PSDRUG(+PSJDD,0)),U)_U_$SELECT((ON["U")&($PIECE(PSJDD,U,2)=""):1,(ON["U")&($EXTRACT($PIECE(PSJDD,U,2))="."):"0"_$PIECE(PSJDD,U,2),1:$PIECE(PSJDD,U,2))_U_$PIECE(PSJDD,U,3)
- +10 ;add High Risk field to 6th piece of 700 (disp drug) ;*279
- +11 SET $PIECE(^TMP(PSJTMP,$JOB,700,CNT,0),U,6)=+$$GET1^DIQ(50.7,PSJ("OI"),1,"I")
- +12 ;add Prompt For Removal In BCMA fld to 7th ;*315
- +13 SET $PIECE(^TMP(PSJTMP,$JOB,700,CNT,0),U,7)=+PSJ("MRRFL")
- +14 ;add Haz Handle & Dispose flags at 8 & 9th pieces *364
- +15 SET $PIECE(^TMP(PSJTMP,$JOB,700,CNT,0),U,8,9)=$PIECE($$HAZ^PSSUTIL(+PSJDD),U,1,2)
- End DoDot:1
- +16 if CNT
- SET ^TMP(PSJTMP,$JOB,700,0)=CNT
- +17 KILL PSJ,PSJDD,PSJDN
- +18 QUIT
- +19 ;
- IVVAR ;* Set variables for IV and pending orders
- +1 NEW CNT,DN,ND,X,Y,CLINIC,OIIEN
- +2 ;*364
- NEW DDIEN
- +3 ;don't send orders to BCMA that fail the Clinic test ;*279
- +4 ; Pending's
- +5 ;*279
- IF ON["P"
- Begin DoDot:1
- +6 ;*279
- DO UDPEND
- +7 ;*279
- SET PSJ("INFRATE")=$PIECE($PIECE($GET(^PS(53.1,ON,8)),U,5),"@")
- End DoDot:1
- IF '$$CLINICS^PSJBCMA($GET(CLINIC),$GET(PSJIGS2B))
- QUIT
- +8 ; IV's
- +9 ;*279
- IF ON["V"
- Begin DoDot:1
- +10 SET X=$GET(^PS(55,DFN,"IV",+ON,0))
- +11 SET PSJ("STARTDT")=$PIECE(X,U,2)
- SET PSJ("STOPDT")=$PIECE(X,U,3)
- +12 SET PSJ("PROVIDER")=$PIECE(X,U,6)
- +13 SET PSJEXIST=$SELECT((PSJ("PROVIDER")'=""):1,1:0)
- +14 SET PSJ("INFRATE")=$PIECE($PIECE(X,U,8),"@")
- SET PSJ("SCHD")=$PIECE(X,U,9)
- +15 SET PSJ("ADM")=$PIECE(X,U,11)
- SET PSJ("AUTO")=$PIECE(X,U,12)
- SET PSJ("STATUS")=$PIECE(X,U,17)
- +16 SET PSJ("FREQ")=$PIECE(X,U,15)
- SET PSJ("IVTYPE")=$PIECE(X,U,4)
- +17 SET PSJ("INSYR")=$PIECE(X,U,5)
- SET PSJ("CPRS")=$PIECE(X,U,21)
- SET PSJ("CHEMO")=$PIECE(X,U,23)
- +18 SET X=$GET(^PS(55,DFN,"IV",+ON,.2))
- +19 SET PSJ("OI")=$PIECE(X,U)
- SET PSJ("DO")=""
- SET PSJ("PRI")=$PIECE(X,U,4)
- SET PSJ("FLG")=$PIECE(X,U,7)
- SET PSJ("COM")=""
- SET PSJ("SRC")=""
- +20 IF PSJ("FLG")
- Begin DoDot:2
- +21 NEW S1,A,B,C
- +22 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
- +23 if A'="G"
- QUIT
- +24 SET PSJ("SRC")=$SELECT(B["FLAGGED BY PHARM":"PHARMACIST",B["FLAGGED BY CPRS":"CPRS",1:"")
- +25 SET PSJ("COM")=$PIECE(B," ",4,99)
- End DoDot:3
- IF PSJ("SRC")]""
- QUIT
- End DoDot:2
- +26 SET PSJ("MR")=$PIECE(X,U,3)
- +27 SET X=$GET(^PS(55,DFN,"IV",+ON,4))
- +28 SET PSJ("NURSE")=$PIECE(X,U)
- +29 SET PSJ("PHARM")=$PIECE(X,U,4)
- +30 SET X=$GET(^PS(55,DFN,"IV",+ON,2))
- +31 SET PSJ("LDT")=$PIECE(X,U)
- +32 SET PSJ("PREV")=$PIECE(X,U,5)
- SET PSJ("FOLLOW")=$PIECE(X,U,6)
- +33 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)),"^")
- +34 ; SCHD var required to shorten $Select
- NEW SCHD
- SET SCHD=PSJ("SCHD")
- +35 SET PSJ("STC")=$$ONE^PSJBCMA(DFN,ON,SCHD,PSJ("STARTDT"),PSJ("STOPDT"))
- +36 IF PSJ("STC")=""!(PSJ("STC")="C")
- SET PSJ("STC")=$SELECT(SCHD["PRN":"P",1:"C")
- +37 IF PSJ("STC")="C"
- SET PSJ("STC")=$SELECT($$ONCALL^PSJBCMA(PSJ("SCHD")):"OC",1:"C")
- +38 SET PSJ("NURSE")=$PIECE($GET(^PS(55,DFN,"IV",+ON,4)),U)
- +39 ;*279
- SET CLINIC=$GET(^PS(55,DFN,"IV",+ON,"DSS"))
- End DoDot:1
- IF '$$CLINICS^PSJBCMA($GET(CLINIC),$GET(PSJIGS2B))
- QUIT
- +40 ;
- +41 DO TMP
- +42 SET X=$PIECE($GET(^PS(55,DFN,"IV",+ON,1)),U)
- if X]""
- SET ^TMP(PSJTMP,$JOB,6)=X
- +43 SET CNT=0
- +44 FOR X=0:0
- SET X=$ORDER(@(F_",""AD"","_X_")"))
- if 'X
- QUIT
- Begin DoDot:1
- +45 ;,AOINAME=$$OIDF^PSJLMUT1(+$P(DN,U,11)) I AOINAME["NOTFOUND" S AOINAME=""
- SET ND=$GET(@(F_",""AD"","_X_",0)"))
- SET DN=$GET(^PS(52.6,+ND,0))
- +46 ;_U_U_$P(DN,U,11)_U_AOINAME_U_AOIDF
- SET CNT=CNT+1
- SET ^TMP(PSJTMP,$JOB,850,CNT,0)=+ND_U_$PIECE(DN,U)_U_$PIECE(ND,U,2)_U_$PIECE(ND,U,3)
- +47 ;add High Risk field to 6th piece of 850 (additive) ;*279
- +48 SET $PIECE(^TMP(PSJTMP,$JOB,850,CNT,0),U,6)=$$HRFLG^PSJBCMA(+ND,"A")
- +49 ;add Haz Handle & Dispose flags at 7 & 8th pieces of additive *364
- +50 SET DDIEN=+$PIECE($GET(^PS(52.6,+ND,0)),U,2)
- +51 SET $PIECE(^TMP(PSJTMP,$JOB,850,CNT,0),U,7,8)=$PIECE($$HAZ^PSSUTIL(DDIEN),U,1,2)
- End DoDot:1
- +52 ;
- +53 if CNT
- SET ^TMP(PSJTMP,$JOB,850,0)=CNT
- SET CNT=0
- +54 FOR X=0:0
- SET X=$ORDER(@(F_",""SOL"","_X_")"))
- if 'X
- QUIT
- Begin DoDot:1
- +55 ;,SOINAME=$$OIDF^PSJLMUT1(+$P(DN,U,11)) I SOINAME["NOTFOUND" S SOINAME=""
- SET ND=$GET(@(F_",""SOL"","_X_",0)"))
- SET DN=$GET(^PS(52.7,+ND,0))
- +56 ;_U_U_$P(DN,U,11)_U_SOINAME_U_SOIDF
- SET CNT=CNT+1
- SET ^TMP(PSJTMP,$JOB,950,CNT,0)=+ND_U_$PIECE(DN,U)_U_$PIECE(ND,U,2)_U_$PIECE(DN,U,4)
- +57 ;add High Risk field to 6th piece of 950 (solution) ;*279
- +58 SET $PIECE(^TMP(PSJTMP,$JOB,950,CNT,0),U,6)=$$HRFLG^PSJBCMA(+ND,"S")
- +59 ;add Haz Handle & Dispose flags at 7 & 8th pieces of solution *364
- +60 SET DDIEN=+$PIECE($GET(^PS(52.7,+ND,0)),U,2)
- +61 SET $PIECE(^TMP(PSJTMP,$JOB,950,CNT,0),U,7,8)=$PIECE($$HAZ^PSSUTIL(DDIEN),U,1,2)
- End DoDot:1
- +62 if CNT
- SET ^TMP(PSJTMP,$JOB,950,0)=CNT
- +63 KILL PSJ
- +64 SET X1=0
- +65 FOR
- SET X1=$ORDER(^PS(55,DFN,"IVBCMA",X1))
- if 'X1
- QUIT
- Begin DoDot:1
- +66 SET XX=$GET(^PS(55,DFN,"IVBCMA",X1,0))
- if $PIECE(XX,"^",2)'=+ON
- QUIT
- SET PSJBCID=$PIECE(XX,"^")
- SET X2=0
- +67 FOR I=1:1
- SET X2=$ORDER(^PS(55,DFN,"IVBCMA",X1,"AD",X2))
- if 'X2
- QUIT
- Begin DoDot:2
- +68 SET X=^(X2,0)
- SET ^TMP(PSJTMP,$JOB,800,PSJBCID,I)=+X_"^"_$SELECT($DATA(^PS(52.6,+X,0)):$PIECE(^(0),"^"),1:"*****")_"^"_$PIECE(X,"^",2,99)
- +69 ;add High Risk field to 6th piece of 800 (additive) ;*279
- +70 SET $PIECE(^TMP(PSJTMP,$JOB,800,PSJBCID,I),U,6)=$$HRFLG^PSJBCMA(+X,"A")
- End DoDot:2
- +71 IF I>1
- SET ^TMP(PSJTMP,$JOB,800,PSJBCID,0)=I-1
- +72 SET X2=0
- +73 FOR I=1:1
- SET X2=$ORDER(^PS(55,DFN,"IVBCMA",X1,"SOL",X2))
- if 'X2
- QUIT
- Begin DoDot:2
- +74 SET X=^(X2,0)
- SET ^TMP(PSJTMP,$JOB,900,PSJBCID,I)=$PIECE(X,"^")_"^"_$SELECT($DATA(^PS(52.7,$PIECE(X,"^"),0)):$PIECE(^(0),"^"),1:"*****")_"^"_$PIECE(X,"^",2,99)
- +75 ;add High Risk field to 6th piece of 900 (solution) ;*279
- +76 SET $PIECE(^TMP(PSJTMP,$JOB,900,PSJBCID,I),U,6)=$$HRFLG^PSJBCMA(+X,"S")
- End DoDot:2
- +77 IF I>1
- SET ^TMP(PSJTMP,$JOB,900,PSJBCID,0)=I-1
- +78 SET ^TMP(PSJTMP,$JOB,1000,PSJBCID)=$PIECE(XX,"^",6)_"^"_$PIECE(XX,"^",8)_"^"_$PIECE(XX,"^",7)
- End DoDot:1
- +79 QUIT
- +80 ;
- UDPEND ;
- +1 SET X=$GET(@(F_",0)"))
- +2 ;get clinic node per F = global file ;*279
- +3 IF $PIECE(F,",")[53.1
- SET CLINIC=$GET(@(F_",""DSS"")"))
- +4 IF $PIECE(F,",")[55
- SET CLINIC=$GET(@(F_",8)"))
- +5 ;
- +6 SET PSJ("PROVIDER")=$PIECE(X,U,2)
- +7 SET PSJEXIST=$SELECT((PSJ("PROVIDER")'=""):1,1:0)
- +8 SET PSJ("MR")=$PIECE(X,U,3)
- SET PSJ("SM")=$PIECE(X,U,5)
- SET PSJ("HSM")=$PIECE(X,U,6)
- +9 SET PSJ("ST")=$PIECE(X,U,7)
- SET PSJ("STATUS")=$PIECE(X,U,9)
- +10 SET PSJ("LDT")=$PIECE(X,U,16)
- +11 if ON["U"
- SET PSJ("NGIVEN")=$PIECE(X,U,22)
- +12 SET PSJ("SMYN")=$SELECT(+PSJ("SM"):"YES",1:"NO")
- +13 SET PSJ("HSMYN")=$SELECT(+PSJ("HSM"):"YES",1:"NO")
- +14 SET PSJ("CPRS")=$PIECE(X,U,21)
- SET PSJ("PREV")=$PIECE(X,U,25)
- SET PSJ("FOLLOW")=$PIECE(X,U,26)
- +15 SET X=$GET(@(F_",.2)"))
- +16 SET PSJ("OI")=$PIECE(X,U)
- 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")=""
- +17 IF PSJ("FLG")
- Begin DoDot:1
- +18 NEW S1,A,B,C
- +19 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
- +20 if A'=7000&(A'=7020)
- QUIT
- +21 SET PSJ("SRC")=$SELECT(A=7000:"PHARMACIST",A=7020:"CPRS",1:"")
- +22 SET PSJ("COM")=$GET(@(F_",13)"))
- End DoDot:2
- IF PSJ("SRC")]""
- QUIT
- End DoDot:1
- +23 SET X=$GET(@(F_",2)"))
- +24 SET PSJ("SCHD")=$PIECE(X,U)
- SET PSJ("STARTDT")=$PIECE(X,U,2)
- +25 SET PSJ("STC")=PSJ("ST")
- +26 IF PSJ("ST")="R"!(PSJ("ST")="C")
- SET PSJ("STC")=$SELECT(PSJ("SCHD")["PRN":"P",$$ONCALL^PSJBCMA(PSJ("SCHD")):"OC",$$ONE^PSJBCMA(DFN,ON,PSJ("SCHD"))="O":"O",1:"C")
- +27 IF PSJ("STC")="O"
- SET PSJ("ST")="O"
- +28 ;*315 prev stop date for one times
- SET PSJ("PRSTOPDT")=$PIECE(X,U,3)
- +29 SET PSJ("STOPDT")=$PIECE(X,U,4)
- SET PSJ("ADM")=$PIECE(X,U,5)
- +30 SET PSJ("FREQ")=$PIECE(X,U,6)
- +31 ;save Duration, remove times, & MRR code / convert code 2 = 1 or 3 ;*315
- +32 SET X=$GET(@(F_",2.1)"))
- SET PSJ("DOA")=$PIECE(X,U)
- SET PSJ("RMTM")=$PIECE(X,U,2)
- SET PSJ("MRRFL")=+$PIECE(X,U,4)
- +33 IF PSJ("MRRFL")=2
- SET PSJ("MRRFL")=$SELECT(PSJ("DOA")>0:3,1:1)
- +34 ;if DOA is null, then use FREQ for DOA If below true:
- +35 SET PSJ("DOA")=$SELECT(PSJ("DOA")<1:$GET(PSJ("FREQ")),1:PSJ("DOA"))
- +36 ;
- +37 SET X=$GET(@(F_",4)"))
- +38 SET PSJ("NURSE")=$PIECE(X,U)
- SET PSJ("AUTO")=$PIECE(X,U,11)
- +39 if ON["U"
- SET PSJ("PHARM")=+$PIECE(X,U,3)
- +40 ; the naked reference on the line below refers to the full reference created by indirect reference to F, where F may refer to ^PS(53.1 or the IV or UD multiple ^PS(55
- +41 SET PSJ("SIOPI")=$SELECT($PIECE($GET(@(F_",6)")),"^",2)&($PIECE($GET(@(F_",6)")),"^")'=""):"!",1:"")_$$ENSET^PSJBCMA($PIECE($GET(^(6)),"^"))
- +42 NEW FON
- SET FON=ON
- DO SIOPI^PSJBCMA
- +43 QUIT
- +44 ;
- TMP ;* Setup ^TMP that have common fields between IV and U/D
- +1 NEW CLNAME,CLNAMPTR
- +2 DO NAME(PSJ("PROVIDER"),.PSJNAME,"","")
- +3 SET PSJ("PRONAME")=PSJNAME
- KILL PSJNAME
- +4 IF $DATA(PSJ("PHARM"))
- Begin DoDot:1
- +5 DO NAME(PSJ("PHARM"),.PSJNAME,.PSJINIT,.PSJPIEN)
- +6 SET PSJ("PHARM")=PSJPIEN
- SET PSJ("PNAME")=PSJNAME
- SET PSJ("PINIT")=PSJINIT
- KILL PSJNAME,PSJINIT,PSJPIEN
- End DoDot:1
- +7 IF +PSJ("NURSE")
- Begin DoDot:1
- +8 DO NAME(PSJ("NURSE"),.PSJNAME,.PSJINIT,"")
- +9 SET PSJ("NNAME")=PSJNAME
- SET PSJ("NINIT")=PSJINIT
- KILL PSJNAME,PSJINIT
- End DoDot:1
- +10 SET A=$GET(^PS(51.2,+PSJ("MR"),0))
- SET PSJ("MRNM")=$PIECE(A,U)
- SET PSJ("MRABB")=$PIECE(A,U,3)
- SET PSJ("MRPIJ")=$PIECE(A,U,8)
- SET PSJ("MRIVP")=$PIECE(A,U,9)
- +11 ;*267 Std Rte name
- SET PSJ("MRSTDRNM")=$$GET1^DIQ(51.2,+PSJ("MR"),10)
- +12 SET PSJ("OINAME")=$$OIDF^PSJLMUT1(+PSJ("OI"))
- IF PSJ("OINAME")["NOT FOUND"
- SET PSJ("OINAME")=""
- +13 SET PSJ("OIDF")=$$GET1^DIQ(50.7,+PSJ("OI"),.02)
- +14 IF PSJ("OINAME")=""
- SET PSJ("OIDF")=""
- +15 SET PSJ("LDTN")=$$DATE(PSJ("LDT"))
- +16 SET PSJ("STARTDTN")=$$DATE(PSJ("STARTDT"))
- +17 SET PSJ("STOPDTN")=$$DATE(PSJ("STOPDT"))
- +18 SET X=$SELECT(ON["V":PSJ("STC"),1:PSJ("ST"))
- +19 SET PSJ("STNAME")=$SELECT(X="C":"CONTINUOUS",X="O":"ONE TIME",X="P":"PRN",X="R":"FILL ON REQUEST",X="OC":"ON CALL",1:"NOT FOUND")
- +20 ;
- +21 SET ^TMP(PSJTMP,$JOB,0)=DFN_U_+ON_U_ON_U_PSJ("PREV")_U_PSJ("FOLLOW")_U_$GET(PSJ("IVTYPE"))_U_$GET(PSJ("INSYR"))_U_$GET(PSJ("CHEMO"))_U_PSJ("CPRS")
- +22 ;add Clinic name & IEN ptr to TMP 0 node (pieces 11,12) *279
- +23 ;piece 11 determines if order is a CO or IM for BCMA VDL's *279
- +24 ;CL IEN & valid appt date *279
- IF +CLINIC
- IF $$CLINIC^PSJBCMA(CLINIC)
- Begin DoDot:1
- +25 SET CLNAMPTR=$ORDER(^PS(53.46,"B",+CLINIC,""))
- +26 SET CLNAME=$$GET1^DIQ(53.46,CLNAMPTR_",",.01)
- +27 ;CO ind, CO NAME
- SET $PIECE(^TMP(PSJTMP,$JOB,0),U,11)=CLNAME
- +28 ;IEN ptr to file 44
- SET $PIECE(^TMP(PSJTMP,$JOB,0),U,12)=+CLINIC
- End DoDot:1
- +29 ;
- +30 SET ^TMP(PSJTMP,$JOB,1)=PSJ("PROVIDER")_U_PSJ("PRONAME")_U_PSJ("MR")_U_PSJ("MRABB")_U_$GET(PSJ("SM"))_U_$GET(PSJ("SMYN"))_U_$GET(PSJ("HSM"))_U_$GET(PSJ("HSMYN"))_U_$GET(PSJ("NGIVEN"))_U_PSJ("STATUS")
- +31 ;*267 Std Rte nam
- SET ^TMP(PSJTMP,$JOB,1)=^TMP(PSJTMP,$JOB,1)_U_$$STATUS(ON,PSJ("STATUS"))_U_$GET(PSJ("AUTO"))_U_$GET(PSJ("MRNM"))_U_PSJ("MRSTDRNM")
- +32 SET ^TMP(PSJTMP,$JOB,1,0)=PSJ("MRPIJ")_U_$GET(PSJ("MRIVP"))
- +33 SET ^TMP(PSJTMP,$JOB,2)=PSJ("OI")_U_PSJ("OINAME")_U_PSJ("DO")_U_$PIECE($GET(PSJ("INFRATE")),"@")_U_$GET(PSJ("SCHD"))_U_PSJ("OIDF")
- +34 SET ^TMP(PSJTMP,$JOB,3)=PSJ("SIOPI")
- +35 SET ^TMP(PSJTMP,$JOB,4)=PSJ("STC")_U_$GET(PSJ("STNAME"))_U_PSJ("LDT")_U_PSJ("LDTN")_U_PSJ("STARTDT")_U_PSJ("STARTDTN")_U_PSJ("STOPDT")_U_PSJ("STOPDTN")_U_$$ADMIN(PSJ("ADM"))_U_$GET(PSJ("ST"))_U_$GET(PSJ("FREQ"))
- +36 ;add DOA, Remove Times, MRR code, & prev stop DT to pieces 12-15 *315
- +37 SET $PIECE(^TMP(PSJTMP,$JOB,4),U,12)=$GET(PSJ("DOA"))
- +38 SET $PIECE(^TMP(PSJTMP,$JOB,4),U,13)=$GET(PSJ("RMTM"))
- +39 SET $PIECE(^TMP(PSJTMP,$JOB,4),U,14)=$GET(PSJ("MRRFL"))
- +40 SET $PIECE(^TMP(PSJTMP,$JOB,4),U,15)=$GET(PSJ("PRSTOPDT"))
- +41 SET ^TMP(PSJTMP,$JOB,5)=$GET(PSJ("NURSE"))_U_$GET(PSJ("NNAME"))_U_$GET(PSJ("NINIT"))_U_$GET(PSJ("PHARM"))_U_$GET(PSJ("PNAME"))_U_$GET(PSJ("PINIT"))
- +42 SET A=$$SNDTSTA^PSJHL4A(PSJ("PRI"),PSJ("SCHD"))
- +43 SET ^TMP(PSJTMP,$JOB,7)=$SELECT(A=1:0,1:1)_U_PSJ("FLG")_U_PSJ("SRC")_U_PSJ("COM")
- +44 QUIT
- +45 ;
- NAME(X,NAME,INIT,IEN) ;Lookup in ^VA(200.
- +1 ;X = IEN or Name in ^VA(200
- +2 ;IEN = Return IEN in ^VA(200
- +3 ;NAME = Return the name in 200
- +4 ;INIT = Return the initial
- +5 NEW DIC,Y
- +6 SET DIC="^VA(200,"
- SET DIC(0)="NZ"
- DO ^DIC
- +7 SET IEN=+Y
- +8 SET NAME=$GET(Y(0,0))
- +9 SET INIT=$PIECE($GET(Y(0)),U,2)
- +10 QUIT
- +11 ;
- DATE(Y) ; FM internal date/time to user readable, 4 digit year
- +1 ; Y - date in FileMan internal format
- +2 IF $GET(Y)
- SET Y=Y_$EXTRACT(".",Y'[".")_"0000"
- QUIT $EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_($EXTRACT(Y,1,3)+1700)_" "_$EXTRACT(Y,9,10)_":"_$EXTRACT(Y,11,12)
- +3 QUIT "********"
- +4 ;
- STATUS(ON,X) ;
- +1 ; ON = IEN_"I/U/P"
- +2 ; X = STATUS
- +3 IF X="P"
- QUIT $SELECT(ON["P":"PENDING",ON["V":"PURGE",1:"NOT FOUND")
- +4 QUIT $SELECT(X="A":"ACTIVE",X="D":"DISCONTINUED",X="E":"EXPIRED",X="H":"HOLD",X="R":"RENEWED",X="RE":"REINSTATED",X="N":"NON-VERFIED",X="DE":"DISCONTINUED (EDIT)",X="O":"ON CALL",1:"NOT FOUND")
- +5 ;
- ADMIN(X) ; N
- +1 NEW Y,PSJADM,PSJX
- SET PSJADM=""
- +2 IF X=""
- QUIT ""
- +3 FOR Y=1:1:$LENGTH(X,"-")
- SET PSJX=$EXTRACT($PIECE(X,"-",Y)_"0000",1,4)
- Begin DoDot:1
- +4 SET PSJADM=PSJADM_$SELECT(PSJADM]"":"-",1:"")_PSJX
- End DoDot:1
- +5 QUIT PSJADM
- +6 ;
- MVOPIAL(DFN,PSJI1,PSJI2) ; Move Other Print Info Activity log entries from NV order to Active order, during Verification
- +1 if '$GET(DFN)!'$GET(PSJI1)!'$GET(PSJI2)
- QUIT
- if '$DATA(^PS(55,DFN,"IV",+PSJI2,0))
- QUIT
- +2 IF PSJI1["P"
- IF PSJI2["V"
- NEW AL,ALND,PNDND0,TXTLN,TXTCNT
- SET AL=0
- SET ALND=0
- FOR
- SET AL=$ORDER(^PS(53.1,+PSJI1,"A",AL))
- if 'AL
- QUIT
- IF ^(AL,0)["OTHER PRINT INFO"
- Begin DoDot:1
- +3 ; Don't retain activity log entry if no text
- if '$DATA(^PS(53.1,+PSJI1,"A",AL,1,0))
- QUIT
- +4 SET PNDND0=$GET(^PS(53.1,+PSJI1,"A",AL,0))
- NEW USER,NAME
- SET USER=$PIECE(PNDND0,"^",2)
- DO NAME^PSGSICH(USER,.NAME)
- +5 NEW AL2
- SET AL2=$ORDER(^PS(55,DFN,"IV",+PSJI2,"A"," "),-1)+1
- NEW OPILIN
- SET OPILIN=+$ORDER(^PS(53.1,+PSJI1,"A",AL,1,""),-1)
- +6 SET ^PS(55,DFN,"IV",+PSJI2,"A",AL2,0)=AL_"^E^"_NAME_"^^"_$PIECE(PNDND0,"^")_"^"_USER
- SET ^PS(55,DFN,"IV",+PSJI2,"A",AL2,1,0)="^55.151^1^1"
- +7 SET ^PS(55,DFN,"IV",+PSJI2,"A",AL2,1,1,0)="OTHER PRINT INFO"
- +8 SET TXTLN=0
- FOR TXTCNT=0:1
- SET TXTLN=$ORDER(^PS(53.1,+PSJI1,"A",AL,1,TXTLN))
- if 'TXTLN
- QUIT
- Begin DoDot:2
- +9 SET ^PS(55,DFN,"IV",+PSJI2,"A",AL2,2,TXTLN,0)=^PS(53.1,+PSJI1,"A",AL,1,TXTLN,0)
- End DoDot:2
- +10 IF $GET(TXTCNT)
- SET ^PS(55,DFN,"IV",+PSJI2,"A",AL2,2,0)="^^"_+$GET(TXTCNT)_"^"_$GET(TXTCNT)_"^"_+$GET(^PS(53.1,+PSJI1,"A",AL,0))
- Begin DoDot:2
- +11 SET ^PS(55,DFN,"IV",+PSJI2,"A",AL2,1,1,0)="OTHER PRINT INFO"
- End DoDot:2
- End DoDot:1
- +12 QUIT
- +13 ;
- OPIWARN(AFTER) ; Warn user about OPI not printing on IV labels
- +1 NEW DIR
- SET DIR=""
- +2 NEW PSJSTARZ
- SET $PIECE(PSJSTARZ,"*",69)="*"
- WRITE !!?5,$EXTRACT(PSJSTARZ,1,29)," WARNING ",$EXTRACT(PSJSTARZ,1,31)
- +3 WRITE !?5,"**",$SELECT(AFTER:" ",1:" If "),"OTHER PRINT INFO exceeds 60 characters"_$SELECT(AFTER:"! **",1:", **")
- +4 WRITE !?5,"** 'Instructions too long. See Order View or BCMA for full text.' **"
- +5 WRITE !?5,"** will print on the IV label instead of the full text. **",!?5,PSJSTARZ
- +6 WRITE !!
- DO PAUSE^VALM1
- +7 QUIT