- PSJUTL1 ;BIR/MLM-MISC. INPATIENT UTILITIES ;29 Jul 98 / 4:29 PM
- ;;5.0;INPATIENT MEDICATIONS;**15,50,58,260**;16 DEC 97;Build 94
- ;
- ; Reference to ^PSSLOCK is supported by DBIA# 2789.
- ; Reference to ^PS(55 is supported by DBIA# 2191.
- ; Reference to ^PS(50.7 is supported by DBIA# 2180.
- ; Reference to ^PS(52.6 is supported by DBIA# 1231.
- ; Reference to ^PS(52.7 is supported by DBIA# 2173.
- ; Reference to ^PS(59.7 is supported by DBIA# 2181.
- ; Reference to ^PSDRUG is supported by DBIA# 2192.
- ; Reference to ^XPD(9.7 is supported by DBIA# 2197.
- ; Reference to ^PSSDIUTL is supported by DBIA# 5737.
- ;
- CONVERT(DFN,TYPE) ;
- ; Convert existing UD orders to new format. Only run once/patient, and
- ; only converts orders with a stop date<(5.0 Install date-365)
- ; DFN = Patient IEN
- ; TYPE = Background or Interactive mode
- ;
- S TYPE=TYPE&($E($G(IOST))="C")
- ;I '$D(^PS(55,DFN,0))!($P($G(^PS(55,DFN,5.1)),U,11)=1) Q
- ;I $S($P($G(^PS(55,DFN,5.1)),U,11)=1:1,$O(^PS(55,DFN,"IV",0)):0,$O(^PS(55,DFN,5,0)):0,1:'$O(^PS(53.1,"C",DFN,0))) Q
- I $P($G(^PS(55,DFN,5.1)),U,11)=1 Q
- N ADS,ADS1,DDRG,ND,ON,ON1,PSGDT,PSJOI,STAT,STPDT,STS,X,XX,X1,X2
- ;I '$D(^PS(55,DFN,0)) D
- ;I '$D(^PS(55,DFN,0))&(($O(^PS(55,DFN,"IV",0)))!($O(^PS(55,DFN,5,0)))!($O(^PS(53.1,"C",DFN,0)))) D
- I '$D(^PS(55,DFN,0))&($D(^PS(55,DFN))!($O(^PS(53.1,"C",DFN,0)))) D
- .N X,Y,DA,DIK S ^PS(55,DFN,0)=DFN K DIK S DA=DFN,DIK="^PS(55,",DIK(1)=.01 D EN^DIK
- ;I TYPE W !!,"Converting old orders for ",$P($G(^DPT(DFN,0)),U)," to new format."
- S X1=$P($G(^PS(59.7,1,20)),U,2),X2=-365 I 'X1 D NOW^%DTC S X1=$P(%,".")
- D C^%DTC S PSGDT=X
- ;Convert and Backfill orders in 53.1.
- F STAT="D","DE","N","P","U" S STS=$O(^PS(53.1,"AS",STAT)) F ON=0:0 S ON=$O(^PS(53.1,"AS",STAT,DFN,ON)) Q:'ON I '$G(^PS(53.1,ON,.2)) D
- .S PSJOI="",ND=$G(^PS(53.1,+ON,.1)),DDRG=+$G(^PS(53.1,ON,1,+$O(^PS(53.1,ON,1,0)),0)) S:DDRG PSJOI=+$G(^PSDRUG(DDRG,2))
- .I 'PSJOI F DDRG=0:0 S DDRG=$O(^PSDRUG("AP",+ND,DDRG)) Q:'DDRG!PSJOI S PSJOI=+$G(^PSDRUG(DDRG,2)) D
- .; convert pending UD orders that have "I" in 4th piece for TYPE
- .I STAT="P",($P($G(^PS(53.1,ON,0)),"^",4)="I"),(PSJOI) S $P(^PS(53.1,ON,0),"^",4)=$$CNV2(PSJOI)
- .I PSJOI S ^PS(53.1,ON,.2)=PSJOI_U_$P(ND,U,2) W:TYPE "."
- .I PSJOI!($P($G(^PS(53.1,+ON,0)),U,4)="F") D EN1^PSJHL2(DFN,"ZC",ON_"P")
- .; convert order location codes for ^PS(53.1
- .K PSJXX S PSJXX=$G(^PS(53.1,ON,0)) I $L(PSJXX) S $P(PSJXX,"^",25,26)=$$CNV($P(PSJXX,"^",25))_"^"_$$CNV($P(PSJXX,"^",26)) S ^(0)=PSJXX K PSJXX
- ;Convert and Backfill UD orders.
- F STPDT=PSGDT:0 S STPDT=$O(^PS(55,DFN,5,"AUS",STPDT)) Q:'STPDT F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",STPDT,ON)) Q:'ON I '$G(^PS(55,DFN,5,ON,.2)) D
- .S PSJOI="",ND=$G(^PS(55,DFN,5,+ON,.1)),DDRG=$O(^PS(55,DFN,5,ON,1,0)),XX=+$G(^PS(55,DFN,5,ON,1,+DDRG,0)) S:XX PSJOI=+$G(^PSDRUG(XX,2))
- .I 'PSJOI F DDRG=0:0 S DDRG=$O(^PSDRUG("AP",+ND,DDRG)) Q:'DDRG!PSJOI S PSJOI=+$G(^PSDRUG(DDRG,2))
- .I PSJOI S ^PS(55,DFN,5,ON,.2)=PSJOI_U_$P(ND,U,2) W:TYPE "." D EN1^PSJHL2(DFN,"ZC",ON_"U")
- .; convert order location codes for Unit Dose orders
- .K PSJXX S PSJXX=$G(^PS(55,DFN,5,ON,0)) I $L(PSJXX) S $P(PSJXX,"^",25,26)=$$CNV($P(PSJXX,"^",25))_"^"_$$CNV($P(PSJXX,"^",26)) S ^(0)=PSJXX K PSJXX
- ;Convert and Backfill IV orders.
- F STPDT=PSGDT:0 S STPDT=$O(^PS(55,DFN,"IV","AIS",STPDT)) Q:'STPDT F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",STPDT,ON)) Q:'ON I '$G(^PS(55,DFN,"IV",ON,.2)) D
- .S PSJOI="",ND=$G(^PS(55,DFN,"IV",ON,6)) F ADS="AD","SOL" I 'PSJOI F ON1=0:0 S ON1=$O(^PS(55,DFN,"IV",ON,ADS,ON1)) Q:'ON1!PSJOI S XX=+$G(^PS(55,DFN,"IV",ON,ADS,ON1,0)) D
- ..S:XX PSJOI=$S(ADS="AD":$P($G(^PS(52.6,XX,0)),U,11),1:$P($G(^PS(52.7,XX,0)),U,11)) I PSJOI S ^PS(55,DFN,"IV",ON,.2)=PSJOI_U_$P(ND,U,2,3) W:TYPE "."
- .S PSJ200=$P($G(^PS(55,DFN,"IV",ON,2)),U,3) Q:PSJ200=""
- .S X=$O(^VA(200,"B",PSJ200,0)),XX=$O(^VA(200,"B",PSJ200,X))
- .I 'X!XX S ^XTMP("PSJ NEW PERSON",PSJ200,DFN,ON)="" Q
- .S $P(^PS(55,DFN,"IV",ON,2),U,11)=X
- .D EN1^PSJHL2(DFN,"ZC",ON_"V")
- .; convert order location codes for IVs
- .K PSJXX S PSJXX=$G(^PS(55,DFN,"IV",ON,2)) I $L(PSJXX) S $P(PSJXX,"^",5,6)=$$CNV($P(PSJXX,"^",5))_"^"_$$CNV($P(PSJXX,"^",6)) S ^(2)=PSJXX K PSJXX
- ;Delete Unreleased entries after converting.
- F ON=0:0 S ON=$O(^PS(53.1,"AS","U",DFN,ON)) Q:'ON I $G(^PS(53.1,ON,.2)) S DIK="^PS(53.1,",DA=ON D ^DIK K DIK
- S:$D(^PS(55,DFN,0)) $P(^PS(55,DFN,5.1),U,11)=1
- Q
- ;
- NFWS(DFN,ON,PSJPWD) ; Determine if order is NF or WS
- ;Input: DFN - Patient IEN
- ; ON - Order #_Order Code
- ; PSJPWD - IEN of patient's ward
- ; Where Order Code IDs order location ("P":53.1; "U":55.06,1:55.01)
- ;Output: NF flag^WS flag^Self Med^Hosp Supplied Self Med
- N ND
- Q:$S(ON["U":0,1:ON'["P") ""
- ;S PSJPWD="",X=$P($G(^DPT(DFN,.1)),U) I X]"" S PSJPWD=$O(^DIC(42,"B",X,0))
- S PSJ="",PSJREF=$S(ON["P":"^PS(53.1,",1:"^PS(55,"_DFN_",5,")_+ON_","
- F PSJDD=0:0 S PSJDD=$O(@(PSJREF_"1,"_PSJDD_")")) Q:'PSJDD S ND=$G(^(PSJDD,0)) D CHKDD
- S $P(PSJ,U,3,4)=$P($G(@(PSJREF_"0)")),U,5,6)
- Q PSJ
- ;
- CHKDD ; Determine if dispense drug is NF or WS
- ;
- S:$P($G(^PSDRUG(+ND,0)),U,9) $P(PSJ,U)=1
- S:$$WSCHK^PSJO(PSJPWD,+ND) $P(PSJ,U,2)=1
- Q
- FIND ;
- F DFN=0:0 S DFN=$O(^PS(55,DFN)) Q:'DFN D
- .I $O(^PS(55,DFN,5,0))!$O(^PS(55,DFN,"IV",0)) D
- ..I '$P($G(^PS(55,DFN,5.1)),U,11) W !,DFN
- Q
- ;
- CNV(PSJM) ; converts order location codes to just 'U' 'P' and 'V'
- I PSJM="" Q PSJM
- I PSJM["V" Q PSJM
- I PSJM["A"!(PSJM["O") Q ($E(PSJM,1,$L(+PSJM))_"U")
- I PSJM["N"!(PSJM["P") Q ($E(PSJM,1,$L(+PSJM))_"P")
- Q PSJM
- CNV2(IEN507) ; converts pending orders with 3rd piece set to "I"
- ; is the orderable item marked for IV ?
- I $P($G(^PS(50.7,IEN507,0)),"^",3)=1 Q "I"
- E Q "U"
- Q
- CNIV(DFN) ;Converts OI on active and pending IV orders for POE
- ;for all patients or a selected patient
- NEW ON,PSGDT,STPDT,START,PSJX
- I $G(DFN) D Q:PSJX>1
- . S PSJX=$P($G(^PS(55,DFN,5.1)),U,11)
- . Q:PSJX=3
- . I PSJX=2 D MARKIV^PSJUTL3(DFN) Q
- ;I '$D(^XTMP("PSSCONA")),'$D(^XTMP("PSSCONS")) Q
- D NOW^%DTC S START=%
- S X1=DT_".0001",X2=-365
- D C^%DTC S PSGDT=X
- I $G(DFN) D CNIV1(DFN),MARKIV^PSJUTL3(DFN) Q
- NEW DFN
- F DFN=0:0 S DFN=$O(^PS(55,DFN)) Q:'DFN D CNIV1(DFN),MARKIV^PSJUTL3(DFN)
- D ENIVUD^PSJ0050
- D SEND
- Q
- CNIV1(DFN) ;
- ;I $P($G(^PS(55,DFN,5.1)),U,11)=2 Q
- Q:'$$L^PSSLOCK(DFN,0)
- S $P(^PS(55,DFN,5.1),U,11)=2
- I '$D(^XTMP("PSSCONA")),'$D(^XTMP("PSSCONS")) D UL^PSSLOCK(DFN) Q
- F STPDT=PSGDT:0 S STPDT=$O(^PS(55,DFN,"IV","AIS",STPDT)) Q:'STPDT D
- . F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",STPDT,ON)) Q:'ON D IVCHK
- F ON=0:0 S ON=$O(^PS(53.1,"AS","P",DFN,ON)) Q:'ON D PENDING
- D UL^PSSLOCK(DFN)
- Q
- IVCHK ;Match AD/SOL against Xtmp
- NEW PSJAD,PSJCNR,PSJOI,PSJSOL,PSJXAD,PSJXNOI,PSJXSOL
- S PSJOI=+$G(^PS(55,DFN,"IV",ON,.2)) Q:'+PSJOI
- ;
- ;Set local array for AD/SOL from the order
- F PSJAD=0:0 S PSJAD=$O(^PS(55,DFN,"IV",ON,"AD",PSJAD)) Q:'PSJAD D
- . I $G(^PS(55,DFN,"IV",ON,"AD",PSJAD,0)) S PSJAD(+^(0))=""
- F PSJSOL=0:0 S PSJSOL=$O(^PS(55,DFN,"IV",ON,"SOL",PSJSOL)) Q:'PSJSOL D
- . I $G(^PS(55,DFN,"IV",ON,"SOL",PSJSOL,0)) S PSJSOL(+^(0))=""
- D MATCH,UPD(ON_"V")
- Q
- ;
- MATCH ;If AD/SOL from XTMP matches to AD/SOL within the order, set new OI array
- K PSJXNOI
- F PSJXAD=0:0 S PSJXAD=$O(^XTMP("PSSCONA",+PSJOI,PSJXAD)) Q:'PSJXAD D
- . I $D(PSJAD(PSJXAD)) S PSJXNOI(+^XTMP("PSSCONA",+PSJOI,PSJXAD))=""
- F PSJXSOL=0:0 S PSJXSOL=$O(^XTMP("PSSCONS",+PSJOI,PSJXSOL)) Q:'PSJXSOL D
- . I $D(PSJSOL(PSJXSOL)) S PSJXNOI(+^XTMP("PSSCONS",+PSJOI,PSJXSOL))=""
- Q
- ;
- UPD(ON) ;Loop thru the new OI array
- NEW PSJCNT S PSJCNT=0
- F X=0:0 S X=$O(PSJXNOI(X)) Q:'X S PSJCNT=PSJCNT+1
- I PSJCNT=1 D
- . S PSJXNOI=$O(PSJXNOI(0))
- . I +PSJOI=PSJXNOI Q
- . S X=$P($G(^PS(50.7,PSJXNOI,0)),U,4)
- . I X]"",(X'>DT) Q
- . ;/W !,"DFN: ",DFN," ON: ",ON," NEW OI: ",PSJXNOI
- . S:ON["V" $P(^PS(55,DFN,"IV",+ON,.2),U,1)=+PSJXNOI
- . S:ON["P" $P(^PS(53.1,+ON,.2),U,1)=+PSJXNOI
- . D EN1^PSJHL2(DFN,"ZC",ON)
- . D EN^PSJ0050(DFN,+ON,+PSJOI,PSJXNOI)
- Q
- PENDING ;Converting Pending IV order with Ad/Sol
- NEW PSJAD,PSJOI,PSJSOL,PSJXNOI
- S X=$P($G(^PS(53.1,ON,0)),U,4) I $S(X="I":0,X="F":0,1:1) Q
- S PSJOI=+$G(^PS(53.1,ON,.2)) Q:'+PSJOI
- ;
- ;If pending has no AD/SOL, and on 1 new OI matched to old OI then update.
- I '$D(^PS(53.1,ON,"AD")),'$D(^PS(53.1,ON,"SOL")) D Q
- . F X=0:0 S X=$O(^XTMP("PSSCONA",PSJOI,X)) Q:'X S PSJXNOI(+^(X))=""
- . F X=0:0 S X=$O(^XTMP("PSSCONS",PSJOI,X)) Q:'X S PSJXNOI(+^(X))=""
- . D UPD(ON_"P")
- ;
- ;Loop thru the pending AD/SOL
- F PSJAD=0:0 S PSJAD=$O(^PS(53.1,ON,"AD",PSJAD)) Q:'PSJAD D
- . I $G(^PS(53.1,ON,"AD",PSJAD,0)) S PSJAD(+^(0))=""
- F PSJSOL=0:0 S PSJSOL=$O(^PS(55,ON,"SOL",PSJSOL)) Q:'PSJSOL D
- . I $G(^PS(53.1,ON,"SOL",PSJSOL,0)) S PSJSOL(+^(0))=""
- D MATCH,UPD(ON_"P")
- Q
- SEND ;Send mail message
- NEW DIFROM,XMDUZ,XMSUB,XMTEXT,XMY,STOP,LINE
- D NOW^%DTC S STOP=%
- S LINE(1)="The conversion was first started: "_$$FMTE^XLFDT(START)
- S LINE(2)="It ran to completion: "_$$FMTE^XLFDT(STOP)
- S XMSUB="Inpatient Meds IV conversion",XMTEXT="LINE("
- S XMDUZ="Inpatient Meds POE"
- S XMY(+DUZ)="" D ^XMD
- Q
- PSSDGCK ;Run Drug Check Util
- D ^PSSDIUTL
- Q
- INSTLDT() ;Return the date PSJ*5*58 was first installed
- NEW DIC,X,Y
- S X=$O(^XPD(9.7,"B","PSJ*5.0*58",0))
- Q:'+X ""
- S DIC="^XPD(9.7,",DIC(0)="NZ" D ^DIC
- Q $P($G(Y(0)),U,3)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJUTL1 9392 printed Feb 18, 2025@23:35:34 Page 2
- PSJUTL1 ;BIR/MLM-MISC. INPATIENT UTILITIES ;29 Jul 98 / 4:29 PM
- +1 ;;5.0;INPATIENT MEDICATIONS;**15,50,58,260**;16 DEC 97;Build 94
- +2 ;
- +3 ; Reference to ^PSSLOCK is supported by DBIA# 2789.
- +4 ; Reference to ^PS(55 is supported by DBIA# 2191.
- +5 ; Reference to ^PS(50.7 is supported by DBIA# 2180.
- +6 ; Reference to ^PS(52.6 is supported by DBIA# 1231.
- +7 ; Reference to ^PS(52.7 is supported by DBIA# 2173.
- +8 ; Reference to ^PS(59.7 is supported by DBIA# 2181.
- +9 ; Reference to ^PSDRUG is supported by DBIA# 2192.
- +10 ; Reference to ^XPD(9.7 is supported by DBIA# 2197.
- +11 ; Reference to ^PSSDIUTL is supported by DBIA# 5737.
- +12 ;
- CONVERT(DFN,TYPE) ;
- +1 ; Convert existing UD orders to new format. Only run once/patient, and
- +2 ; only converts orders with a stop date<(5.0 Install date-365)
- +3 ; DFN = Patient IEN
- +4 ; TYPE = Background or Interactive mode
- +5 ;
- +6 SET TYPE=TYPE&($EXTRACT($GET(IOST))="C")
- +7 ;I '$D(^PS(55,DFN,0))!($P($G(^PS(55,DFN,5.1)),U,11)=1) Q
- +8 ;I $S($P($G(^PS(55,DFN,5.1)),U,11)=1:1,$O(^PS(55,DFN,"IV",0)):0,$O(^PS(55,DFN,5,0)):0,1:'$O(^PS(53.1,"C",DFN,0))) Q
- +9 IF $PIECE($GET(^PS(55,DFN,5.1)),U,11)=1
- QUIT
- +10 NEW ADS,ADS1,DDRG,ND,ON,ON1,PSGDT,PSJOI,STAT,STPDT,STS,X,XX,X1,X2
- +11 ;I '$D(^PS(55,DFN,0)) D
- +12 ;I '$D(^PS(55,DFN,0))&(($O(^PS(55,DFN,"IV",0)))!($O(^PS(55,DFN,5,0)))!($O(^PS(53.1,"C",DFN,0)))) D
- +13 IF '$DATA(^PS(55,DFN,0))&($DATA(^PS(55,DFN))!($ORDER(^PS(53.1,"C",DFN,0))))
- Begin DoDot:1
- +14 NEW X,Y,DA,DIK
- SET ^PS(55,DFN,0)=DFN
- KILL DIK
- SET DA=DFN
- SET DIK="^PS(55,"
- SET DIK(1)=.01
- DO EN^DIK
- End DoDot:1
- +15 ;I TYPE W !!,"Converting old orders for ",$P($G(^DPT(DFN,0)),U)," to new format."
- +16 SET X1=$PIECE($GET(^PS(59.7,1,20)),U,2)
- SET X2=-365
- IF 'X1
- DO NOW^%DTC
- SET X1=$PIECE(%,".")
- +17 DO C^%DTC
- SET PSGDT=X
- +18 ;Convert and Backfill orders in 53.1.
- +19 FOR STAT="D","DE","N","P","U"
- SET STS=$ORDER(^PS(53.1,"AS",STAT))
- FOR ON=0:0
- SET ON=$ORDER(^PS(53.1,"AS",STAT,DFN,ON))
- if 'ON
- QUIT
- IF '$GET(^PS(53.1,ON,.2))
- Begin DoDot:1
- +20 SET PSJOI=""
- SET ND=$GET(^PS(53.1,+ON,.1))
- SET DDRG=+$GET(^PS(53.1,ON,1,+$ORDER(^PS(53.1,ON,1,0)),0))
- if DDRG
- SET PSJOI=+$GET(^PSDRUG(DDRG,2))
- +21 IF 'PSJOI
- FOR DDRG=0:0
- SET DDRG=$ORDER(^PSDRUG("AP",+ND,DDRG))
- if 'DDRG!PSJOI
- QUIT
- SET PSJOI=+$GET(^PSDRUG(DDRG,2))
- Begin DoDot:2
- End DoDot:2
- +22 ; convert pending UD orders that have "I" in 4th piece for TYPE
- +23 IF STAT="P"
- IF ($PIECE($GET(^PS(53.1,ON,0)),"^",4)="I")
- IF (PSJOI)
- SET $PIECE(^PS(53.1,ON,0),"^",4)=$$CNV2(PSJOI)
- +24 IF PSJOI
- SET ^PS(53.1,ON,.2)=PSJOI_U_$PIECE(ND,U,2)
- if TYPE
- WRITE "."
- +25 IF PSJOI!($PIECE($GET(^PS(53.1,+ON,0)),U,4)="F")
- DO EN1^PSJHL2(DFN,"ZC",ON_"P")
- +26 ; convert order location codes for ^PS(53.1
- +27 KILL PSJXX
- SET PSJXX=$GET(^PS(53.1,ON,0))
- IF $LENGTH(PSJXX)
- SET $PIECE(PSJXX,"^",25,26)=$$CNV($PIECE(PSJXX,"^",25))_"^"_$$CNV($PIECE(PSJXX,"^",26))
- SET ^(0)=PSJXX
- KILL PSJXX
- End DoDot:1
- +28 ;Convert and Backfill UD orders.
- +29 FOR STPDT=PSGDT:0
- SET STPDT=$ORDER(^PS(55,DFN,5,"AUS",STPDT))
- if 'STPDT
- QUIT
- FOR ON=0:0
- SET ON=$ORDER(^PS(55,DFN,5,"AUS",STPDT,ON))
- if 'ON
- QUIT
- IF '$GET(^PS(55,DFN,5,ON,.2))
- Begin DoDot:1
- +30 SET PSJOI=""
- SET ND=$GET(^PS(55,DFN,5,+ON,.1))
- SET DDRG=$ORDER(^PS(55,DFN,5,ON,1,0))
- SET XX=+$GET(^PS(55,DFN,5,ON,1,+DDRG,0))
- if XX
- SET PSJOI=+$GET(^PSDRUG(XX,2))
- +31 IF 'PSJOI
- FOR DDRG=0:0
- SET DDRG=$ORDER(^PSDRUG("AP",+ND,DDRG))
- if 'DDRG!PSJOI
- QUIT
- SET PSJOI=+$GET(^PSDRUG(DDRG,2))
- +32 IF PSJOI
- SET ^PS(55,DFN,5,ON,.2)=PSJOI_U_$PIECE(ND,U,2)
- if TYPE
- WRITE "."
- DO EN1^PSJHL2(DFN,"ZC",ON_"U")
- +33 ; convert order location codes for Unit Dose orders
- +34 KILL PSJXX
- SET PSJXX=$GET(^PS(55,DFN,5,ON,0))
- IF $LENGTH(PSJXX)
- SET $PIECE(PSJXX,"^",25,26)=$$CNV($PIECE(PSJXX,"^",25))_"^"_$$CNV($PIECE(PSJXX,"^",26))
- SET ^(0)=PSJXX
- KILL PSJXX
- End DoDot:1
- +35 ;Convert and Backfill IV orders.
- +36 FOR STPDT=PSGDT:0
- SET STPDT=$ORDER(^PS(55,DFN,"IV","AIS",STPDT))
- if 'STPDT
- QUIT
- FOR ON=0:0
- SET ON=$ORDER(^PS(55,DFN,"IV","AIS",STPDT,ON))
- if 'ON
- QUIT
- IF '$GET(^PS(55,DFN,"IV",ON,.2))
- Begin DoDot:1
- +37 SET PSJOI=""
- SET ND=$GET(^PS(55,DFN,"IV",ON,6))
- FOR ADS="AD","SOL"
- IF 'PSJOI
- FOR ON1=0:0
- SET ON1=$ORDER(^PS(55,DFN,"IV",ON,ADS,ON1))
- if 'ON1!PSJOI
- QUIT
- SET XX=+$GET(^PS(55,DFN,"IV",ON,ADS,ON1,0))
- Begin DoDot:2
- +38 if XX
- SET PSJOI=$SELECT(ADS="AD":$PIECE($GET(^PS(52.6,XX,0)),U,11),1:$PIECE($GET(^PS(52.7,XX,0)),U,11))
- IF PSJOI
- SET ^PS(55,DFN,"IV",ON,.2)=PSJOI_U_$PIECE(ND,U,2,3)
- if TYPE
- WRITE "."
- End DoDot:2
- +39 SET PSJ200=$PIECE($GET(^PS(55,DFN,"IV",ON,2)),U,3)
- if PSJ200=""
- QUIT
- +40 SET X=$ORDER(^VA(200,"B",PSJ200,0))
- SET XX=$ORDER(^VA(200,"B",PSJ200,X))
- +41 IF 'X!XX
- SET ^XTMP("PSJ NEW PERSON",PSJ200,DFN,ON)=""
- QUIT
- +42 SET $PIECE(^PS(55,DFN,"IV",ON,2),U,11)=X
- +43 DO EN1^PSJHL2(DFN,"ZC",ON_"V")
- +44 ; convert order location codes for IVs
- +45 KILL PSJXX
- SET PSJXX=$GET(^PS(55,DFN,"IV",ON,2))
- IF $LENGTH(PSJXX)
- SET $PIECE(PSJXX,"^",5,6)=$$CNV($PIECE(PSJXX,"^",5))_"^"_$$CNV($PIECE(PSJXX,"^",6))
- SET ^(2)=PSJXX
- KILL PSJXX
- End DoDot:1
- +46 ;Delete Unreleased entries after converting.
- +47 FOR ON=0:0
- SET ON=$ORDER(^PS(53.1,"AS","U",DFN,ON))
- if 'ON
- QUIT
- IF $GET(^PS(53.1,ON,.2))
- SET DIK="^PS(53.1,"
- SET DA=ON
- DO ^DIK
- KILL DIK
- +48 if $DATA(^PS(55,DFN,0))
- SET $PIECE(^PS(55,DFN,5.1),U,11)=1
- +49 QUIT
- +50 ;
- NFWS(DFN,ON,PSJPWD) ; Determine if order is NF or WS
- +1 ;Input: DFN - Patient IEN
- +2 ; ON - Order #_Order Code
- +3 ; PSJPWD - IEN of patient's ward
- +4 ; Where Order Code IDs order location ("P":53.1; "U":55.06,1:55.01)
- +5 ;Output: NF flag^WS flag^Self Med^Hosp Supplied Self Med
- +6 NEW ND
- +7 if $SELECT(ON["U"
- QUIT ""
- +8 ;S PSJPWD="",X=$P($G(^DPT(DFN,.1)),U) I X]"" S PSJPWD=$O(^DIC(42,"B",X,0))
- +9 SET PSJ=""
- SET PSJREF=$SELECT(ON["P":"^PS(53.1,",1:"^PS(55,"_DFN_",5,")_+ON_","
- +10 FOR PSJDD=0:0
- SET PSJDD=$ORDER(@(PSJREF_"1,"_PSJDD_")"))
- if 'PSJDD
- QUIT
- SET ND=$GET(^(PSJDD,0))
- DO CHKDD
- +11 SET $PIECE(PSJ,U,3,4)=$PIECE($GET(@(PSJREF_"0)")),U,5,6)
- +12 QUIT PSJ
- +13 ;
- CHKDD ; Determine if dispense drug is NF or WS
- +1 ;
- +2 if $PIECE($GET(^PSDRUG(+ND,0)),U,9)
- SET $PIECE(PSJ,U)=1
- +3 if $$WSCHK^PSJO(PSJPWD,+ND)
- SET $PIECE(PSJ,U,2)=1
- +4 QUIT
- FIND ;
- +1 FOR DFN=0:0
- SET DFN=$ORDER(^PS(55,DFN))
- if 'DFN
- QUIT
- Begin DoDot:1
- +2 IF $ORDER(^PS(55,DFN,5,0))!$ORDER(^PS(55,DFN,"IV",0))
- Begin DoDot:2
- +3 IF '$PIECE($GET(^PS(55,DFN,5.1)),U,11)
- WRITE !,DFN
- End DoDot:2
- End DoDot:1
- +4 QUIT
- +5 ;
- CNV(PSJM) ; converts order location codes to just 'U' 'P' and 'V'
- +1 IF PSJM=""
- QUIT PSJM
- +2 IF PSJM["V"
- QUIT PSJM
- +3 IF PSJM["A"!(PSJM["O")
- QUIT ($EXTRACT(PSJM,1,$LENGTH(+PSJM))_"U")
- +4 IF PSJM["N"!(PSJM["P")
- QUIT ($EXTRACT(PSJM,1,$LENGTH(+PSJM))_"P")
- +5 QUIT PSJM
- CNV2(IEN507) ; converts pending orders with 3rd piece set to "I"
- +1 ; is the orderable item marked for IV ?
- +2 IF $PIECE($GET(^PS(50.7,IEN507,0)),"^",3)=1
- QUIT "I"
- +3 IF '$TEST
- QUIT "U"
- +4 QUIT
- CNIV(DFN) ;Converts OI on active and pending IV orders for POE
- +1 ;for all patients or a selected patient
- +2 NEW ON,PSGDT,STPDT,START,PSJX
- +3 IF $GET(DFN)
- Begin DoDot:1
- +4 SET PSJX=$PIECE($GET(^PS(55,DFN,5.1)),U,11)
- +5 if PSJX=3
- QUIT
- +6 IF PSJX=2
- DO MARKIV^PSJUTL3(DFN)
- QUIT
- End DoDot:1
- if PSJX>1
- QUIT
- +7 ;I '$D(^XTMP("PSSCONA")),'$D(^XTMP("PSSCONS")) Q
- +8 DO NOW^%DTC
- SET START=%
- +9 SET X1=DT_".0001"
- SET X2=-365
- +10 DO C^%DTC
- SET PSGDT=X
- +11 IF $GET(DFN)
- DO CNIV1(DFN)
- DO MARKIV^PSJUTL3(DFN)
- QUIT
- +12 NEW DFN
- +13 FOR DFN=0:0
- SET DFN=$ORDER(^PS(55,DFN))
- if 'DFN
- QUIT
- DO CNIV1(DFN)
- DO MARKIV^PSJUTL3(DFN)
- +14 DO ENIVUD^PSJ0050
- +15 DO SEND
- +16 QUIT
- CNIV1(DFN) ;
- +1 ;I $P($G(^PS(55,DFN,5.1)),U,11)=2 Q
- +2 if '$$L^PSSLOCK(DFN,0)
- QUIT
- +3 SET $PIECE(^PS(55,DFN,5.1),U,11)=2
- +4 IF '$DATA(^XTMP("PSSCONA"))
- IF '$DATA(^XTMP("PSSCONS"))
- DO UL^PSSLOCK(DFN)
- QUIT
- +5 FOR STPDT=PSGDT:0
- SET STPDT=$ORDER(^PS(55,DFN,"IV","AIS",STPDT))
- if 'STPDT
- QUIT
- Begin DoDot:1
- +6 FOR ON=0:0
- SET ON=$ORDER(^PS(55,DFN,"IV","AIS",STPDT,ON))
- if 'ON
- QUIT
- DO IVCHK
- End DoDot:1
- +7 FOR ON=0:0
- SET ON=$ORDER(^PS(53.1,"AS","P",DFN,ON))
- if 'ON
- QUIT
- DO PENDING
- +8 DO UL^PSSLOCK(DFN)
- +9 QUIT
- IVCHK ;Match AD/SOL against Xtmp
- +1 NEW PSJAD,PSJCNR,PSJOI,PSJSOL,PSJXAD,PSJXNOI,PSJXSOL
- +2 SET PSJOI=+$GET(^PS(55,DFN,"IV",ON,.2))
- if '+PSJOI
- QUIT
- +3 ;
- +4 ;Set local array for AD/SOL from the order
- +5 FOR PSJAD=0:0
- SET PSJAD=$ORDER(^PS(55,DFN,"IV",ON,"AD",PSJAD))
- if 'PSJAD
- QUIT
- Begin DoDot:1
- +6 IF $GET(^PS(55,DFN,"IV",ON,"AD",PSJAD,0))
- SET PSJAD(+^(0))=""
- End DoDot:1
- +7 FOR PSJSOL=0:0
- SET PSJSOL=$ORDER(^PS(55,DFN,"IV",ON,"SOL",PSJSOL))
- if 'PSJSOL
- QUIT
- Begin DoDot:1
- +8 IF $GET(^PS(55,DFN,"IV",ON,"SOL",PSJSOL,0))
- SET PSJSOL(+^(0))=""
- End DoDot:1
- +9 DO MATCH
- DO UPD(ON_"V")
- +10 QUIT
- +11 ;
- MATCH ;If AD/SOL from XTMP matches to AD/SOL within the order, set new OI array
- +1 KILL PSJXNOI
- +2 FOR PSJXAD=0:0
- SET PSJXAD=$ORDER(^XTMP("PSSCONA",+PSJOI,PSJXAD))
- if 'PSJXAD
- QUIT
- Begin DoDot:1
- +3 IF $DATA(PSJAD(PSJXAD))
- SET PSJXNOI(+^XTMP("PSSCONA",+PSJOI,PSJXAD))=""
- End DoDot:1
- +4 FOR PSJXSOL=0:0
- SET PSJXSOL=$ORDER(^XTMP("PSSCONS",+PSJOI,PSJXSOL))
- if 'PSJXSOL
- QUIT
- Begin DoDot:1
- +5 IF $DATA(PSJSOL(PSJXSOL))
- SET PSJXNOI(+^XTMP("PSSCONS",+PSJOI,PSJXSOL))=""
- End DoDot:1
- +6 QUIT
- +7 ;
- UPD(ON) ;Loop thru the new OI array
- +1 NEW PSJCNT
- SET PSJCNT=0
- +2 FOR X=0:0
- SET X=$ORDER(PSJXNOI(X))
- if 'X
- QUIT
- SET PSJCNT=PSJCNT+1
- +3 IF PSJCNT=1
- Begin DoDot:1
- +4 SET PSJXNOI=$ORDER(PSJXNOI(0))
- +5 IF +PSJOI=PSJXNOI
- QUIT
- +6 SET X=$PIECE($GET(^PS(50.7,PSJXNOI,0)),U,4)
- +7 IF X]""
- IF (X'>DT)
- QUIT
- +8 ;/W !,"DFN: ",DFN," ON: ",ON," NEW OI: ",PSJXNOI
- +9 if ON["V"
- SET $PIECE(^PS(55,DFN,"IV",+ON,.2),U,1)=+PSJXNOI
- +10 if ON["P"
- SET $PIECE(^PS(53.1,+ON,.2),U,1)=+PSJXNOI
- +11 DO EN1^PSJHL2(DFN,"ZC",ON)
- +12 DO EN^PSJ0050(DFN,+ON,+PSJOI,PSJXNOI)
- End DoDot:1
- +13 QUIT
- PENDING ;Converting Pending IV order with Ad/Sol
- +1 NEW PSJAD,PSJOI,PSJSOL,PSJXNOI
- +2 SET X=$PIECE($GET(^PS(53.1,ON,0)),U,4)
- IF $SELECT(X="I":0,X="F":0,1:1)
- QUIT
- +3 SET PSJOI=+$GET(^PS(53.1,ON,.2))
- if '+PSJOI
- QUIT
- +4 ;
- +5 ;If pending has no AD/SOL, and on 1 new OI matched to old OI then update.
- +6 IF '$DATA(^PS(53.1,ON,"AD"))
- IF '$DATA(^PS(53.1,ON,"SOL"))
- Begin DoDot:1
- +7 FOR X=0:0
- SET X=$ORDER(^XTMP("PSSCONA",PSJOI,X))
- if 'X
- QUIT
- SET PSJXNOI(+^(X))=""
- +8 FOR X=0:0
- SET X=$ORDER(^XTMP("PSSCONS",PSJOI,X))
- if 'X
- QUIT
- SET PSJXNOI(+^(X))=""
- +9 DO UPD(ON_"P")
- End DoDot:1
- QUIT
- +10 ;
- +11 ;Loop thru the pending AD/SOL
- +12 FOR PSJAD=0:0
- SET PSJAD=$ORDER(^PS(53.1,ON,"AD",PSJAD))
- if 'PSJAD
- QUIT
- Begin DoDot:1
- +13 IF $GET(^PS(53.1,ON,"AD",PSJAD,0))
- SET PSJAD(+^(0))=""
- End DoDot:1
- +14 FOR PSJSOL=0:0
- SET PSJSOL=$ORDER(^PS(55,ON,"SOL",PSJSOL))
- if 'PSJSOL
- QUIT
- Begin DoDot:1
- +15 IF $GET(^PS(53.1,ON,"SOL",PSJSOL,0))
- SET PSJSOL(+^(0))=""
- End DoDot:1
- +16 DO MATCH
- DO UPD(ON_"P")
- +17 QUIT
- SEND ;Send mail message
- +1 NEW DIFROM,XMDUZ,XMSUB,XMTEXT,XMY,STOP,LINE
- +2 DO NOW^%DTC
- SET STOP=%
- +3 SET LINE(1)="The conversion was first started: "_$$FMTE^XLFDT(START)
- +4 SET LINE(2)="It ran to completion: "_$$FMTE^XLFDT(STOP)
- +5 SET XMSUB="Inpatient Meds IV conversion"
- SET XMTEXT="LINE("
- +6 SET XMDUZ="Inpatient Meds POE"
- +7 SET XMY(+DUZ)=""
- DO ^XMD
- +8 QUIT
- PSSDGCK ;Run Drug Check Util
- +1 DO ^PSSDIUTL
- +2 QUIT
- INSTLDT() ;Return the date PSJ*5*58 was first installed
- +1 NEW DIC,X,Y
- +2 SET X=$ORDER(^XPD(9.7,"B","PSJ*5.0*58",0))
- +3 if '+X
- QUIT ""
- +4 SET DIC="^XPD(9.7,"
- SET DIC(0)="NZ"
- DO ^DIC
- +5 QUIT $PIECE($GET(Y(0)),U,3)
