- PSOHLUP ;BIR/RTR-Backfill OERR from Pharmacy ;7/20/96
- ;;7.0;OUTPATIENT PHARMACY;**5,225**;DEC 1997;Build 29
- ;
- ;Pass in patient DFN
- EN(PSOEDFN) ;
- INPT N PSOC
- ;S PSOSHH=$$OTF^OR3CONV(PSOEDFN,$S($G(PSOLOUD):0,1:1))
- Q
- EN2 ;
- I '$P($G(^PS(55,PSOEDFN,0)),"^",6) D UPD S $P(^PS(55,PSOEDFN,0),"^",6)=1
- Q:'$D(^PS(55,+PSOEDFN,0))!('$G(PSOEDFN))
- Q:$P($G(^PS(55,PSOEDFN,0)),"^",6)=2
- N C,Y,DA,IFN,RXP,DFN,PAT,PSODFN,PSOPPQ,PSOPPQR,PSOYEAR,PSOEST,PSOERSTA,PSOPHSTA,X,T,PRU,PSOCV,PTFLAG,III
- ;W:$G(PSOEWRT) !!,"Please wait. Updating CPRS with patient's Outpatient Meds."
- ;F PSOCV=0:0 S PSOCV=$O(^PS(55,PSOEDFN,"P","A",PSOCV)) Q:'PSOCV F PSOPPQR=0:0 S PSOPPQR=$O(^PS(55,PSOEDFN,"P","A",PSOCV,PSOPPQR)) Q:'PSOPPQR D UPD
- S X1=DT,X2=-121 D C^%DTC S PSOYEAR=X
- F PSOPPQ=PSOYEAR:0 S PSOPPQ=$O(^PS(55,PSOEDFN,"P","A",PSOPPQ)) Q:'PSOPPQ F PSOPPQR=0:0 S PSOPPQR=$O(^PS(55,PSOEDFN,"P","A",PSOPPQ,PSOPPQR)) Q:'PSOPPQR D PAT D:$D(^PSRX(PSOPPQR,0))&('$P($G(^PSRX(PSOPPQR,"OR1")),"^",2))&('$G(PTFLAG))
- .Q:'$P($G(^PSRX(PSOPPQR,0)),"^",2)
- .S PSOEST=$S($D(^PSRX(PSOPPQR,"STA")):$P($G(^PSRX(PSOPPQR,"STA")),"^"),1:$P($G(^PSRX(PSOPPQR,0)),"^",15)) Q:PSOEST=10!(PSOEST=13)!(PSOEST=16)!(PSOEST=14)
- .D:'$P($G(^PSRX(PSOPPQR,0)),"^",19)
- ..D:'$P($G(^PSRX(PSOPPQR,"SIG")),"^",2) POP^PSOSIGNO(PSOPPQR)
- ..I $P($G(^PSRX(PSOPPQR,"OR1")),"^")']"",+$G(^PSDRUG(+$P(^PSRX(PSOPPQR,0),"^",6),2)) S $P(^PSRX(PSOPPQR,"OR1"),"^")=+$G(^PSDRUG($P(^PSRX(PSOPPQR,0),"^",6),2))
- ..I $G(^PSRX(PSOPPQR,"SIG"))']"" S ^PSRX(PSOPPQR,"SIG")=$P($G(^PSRX(PSOPPQR,0)),"^",10)_"^"_0 S $P(^PSRX(PSOPPQR,0),"^",10)=""
- ..S ^PSRX(PSOPPQR,"STA")=$P($G(^PSRX(PSOPPQR,0)),"^",15) S $P(^PSRX(PSOPPQR,0),"^",15)=""
- ..S PR=0 F S PR=$O(^PSRX(PSOPPQR,"P",PR)) Q:'PR D
- ...I '$P($G(^PSRX(PSOPPQR,"P",PR,0)),"^") K ^PSRX(PSOPPQR,"P",PR,0) Q
- ...S ^PSRX("ADP",$E($P(^PSRX(PSOPPQR,"P",PR,0),"^"),1,7),PSOPPQR,PR)=""
- ..S $P(^PSRX(PSOPPQR,0),"^",19)=1
- .W:$G(PSOEWRT) "." D EN^PSOHLSN1(PSOPPQR,"ZC","")
- .Q:'$P($G(^PSRX(PSOPPQR,"OR1")),"^",2)
- .S PSOEST=$P($G(^PSRX(PSOPPQR,"STA")),"^")
- .I +$P($G(^PSRX(PSOPPQR,2)),"^",6),$P($G(^(2)),"^",6)<DT S $P(^PSRX(PSOPPQR,"STA"),"^")=11 D ECAN^PSOUTL(PSOPPQR) S PSOEST=11
- .S PSOERSTA=$S(PSOEST=3:"OH",PSOEST=12:"OD",PSOEST=15:"OD",1:"SC"),PSOPHSTA=$S(PSOEST=0:"CM",PSOEST=1:"IP",PSOEST=4:"IP",PSOEST=5:"ZS",PSOEST=11:"ZE",1:"")
- .D EN^PSOHLSN1(PSOPPQR,PSOERSTA,PSOPHSTA,"")
- S $P(^PS(55,PSOEDFN,0),"^",6)=2
- ;W !,"Finished backfilling!",!
- Q
- EN1(PSOEDFN,PSOEWRT) N PSOBCK
- Q:'$G(PSOEDFN)
- S X1=DT,X2=-121 D C^%DTC S PSOYEAR=X
- I $O(^PS(55,PSOEDFN,"P","A",PSOYEAR)) D:'$D(^PS(55,PSOEDFN,0)) ADD(PSOEDFN) D EN2 G INPAT
- D:'$D(^PS(55,PSOEDFN,0))&($D(^PS(55,PSOEDFN))) ADD(PSOEDFN) S:$D(^PS(55,PSOEDFN,0)) $P(^PS(55,PSOEDFN,0),"^",6)=2
- INPAT S X="PSJUTL1" X ^%ZOSF("TEST") I $T D CONVERT^PSJUTL1(PSOEDFN,PSOEWRT)
- Q
- UPD ;Update OERR if not done yet
- N PSLOOP,PSOPPQR
- F PSLOOP=0:0 S PSLOOP=$O(^PS(55,PSOEDFN,"P","A",PSLOOP)) Q:'PSLOOP F PSOPPQR=0:0 S PSOPPQR=$O(^PS(55,PSOEDFN,"P","A",PSLOOP,PSOPPQR)) Q:'PSOPPQR D
- .Q:$G(^PSRX(PSOPPQR,0))=""!('$P($G(^PSRX(PSOPPQR,0)),"^",2))
- .Q:$P(^PSRX(PSOPPQR,0),"^",19)
- .D:'$P($G(^PSRX(PSOPPQR,"SIG")),"^",2) POP^PSOSIGNO(PSOPPQR)
- .I $P($G(^PSRX(PSOPPQR,"OR1")),"^")']"",+$G(^PSDRUG(+$P(^PSRX(PSOPPQR,0),"^",6),2)) S $P(^PSRX(PSOPPQR,"OR1"),"^")=+$G(^PSDRUG($P(^PSRX(PSOPPQR,0),"^",6),2))
- .I $G(^PSRX(PSOPPQR,"SIG"))']"" S ^PSRX(PSOPPQR,"SIG")=$P($G(^PSRX(PSOPPQR,0)),"^",10)_"^"_0 S $P(^PSRX(PSOPPQR,0),"^",10)=""
- .I $G(^PSRX(PSOPPQR,"STA"))']"" S ^PSRX(PSOPPQR,"STA")=$P($G(^PSRX(PSOPPQR,0)),"^",15) S $P(^PSRX(PSOPPQR,0),"^",15)=""
- .S PRU=0 F S PRU=$O(^PSRX(PSOPPQR,"P",PRU)) Q:'PRU D
- ..I '$P($G(^PSRX(PSOPPQR,"P",PRU,0)),"^") K ^PSRX(PSOPPQR,"P",PRU,0) Q
- ..S ^PSRX("ADP",$E($P(^PSRX(PSOPPQR,"P",PRU,0),"^"),1,7),PSOPPQR,PRU)=""
- .S $P(^PSRX(PSOPPQR,0),"^",19)=1
- Q
- PAT ;Check for correct patient
- S PTFLAG=0
- Q:PSOEDFN=$P($G(^PSRX(PSOPPQR,0)),"^",2)
- S PTFLAG=1
- K ^PS(55,PSOEDFN,"P","A",PSOPPQ,PSOPPQR)
- F III=0:0 S III=$O(^PS(55,PSOEDFN,"P",III)) Q:'III I $G(^PS(55,PSOEDFN,"P",III,0))=PSOPPQR K ^PS(55,PSOEDFN,"P",III,0)
- Q
- ADD(PATIEN) ;Add patient to 55 (0 node)
- Q:$D(^PS(55,PATIEN,0))
- N X,Y,DA,DIK
- S ^PS(55,PATIEN,0)=PATIEN K DIK S DA=PATIEN,DIK="^PS(55,",DIK(1)=.01 D EN^DIK
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLUP 4288 printed Jan 18, 2025@03:31:24 Page 2
- PSOHLUP ;BIR/RTR-Backfill OERR from Pharmacy ;7/20/96
- +1 ;;7.0;OUTPATIENT PHARMACY;**5,225**;DEC 1997;Build 29
- +2 ;
- +3 ;Pass in patient DFN
- EN(PSOEDFN) ;
- INPT NEW PSOC
- +1 ;S PSOSHH=$$OTF^OR3CONV(PSOEDFN,$S($G(PSOLOUD):0,1:1))
- +2 QUIT
- EN2 ;
- +1 IF '$PIECE($GET(^PS(55,PSOEDFN,0)),"^",6)
- DO UPD
- SET $PIECE(^PS(55,PSOEDFN,0),"^",6)=1
- +2 if '$DATA(^PS(55,+PSOEDFN,0))!('$GET(PSOEDFN))
- QUIT
- +3 if $PIECE($GET(^PS(55,PSOEDFN,0)),"^",6)=2
- QUIT
- +4 NEW C,Y,DA,IFN,RXP,DFN,PAT,PSODFN,PSOPPQ,PSOPPQR,PSOYEAR,PSOEST,PSOERSTA,PSOPHSTA,X,T,PRU,PSOCV,PTFLAG,III
- +5 ;W:$G(PSOEWRT) !!,"Please wait. Updating CPRS with patient's Outpatient Meds."
- +6 ;F PSOCV=0:0 S PSOCV=$O(^PS(55,PSOEDFN,"P","A",PSOCV)) Q:'PSOCV F PSOPPQR=0:0 S PSOPPQR=$O(^PS(55,PSOEDFN,"P","A",PSOCV,PSOPPQR)) Q:'PSOPPQR D UPD
- +7 SET X1=DT
- SET X2=-121
- DO C^%DTC
- SET PSOYEAR=X
- +8 FOR PSOPPQ=PSOYEAR:0
- SET PSOPPQ=$ORDER(^PS(55,PSOEDFN,"P","A",PSOPPQ))
- if 'PSOPPQ
- QUIT
- FOR PSOPPQR=0:0
- SET PSOPPQR=$ORDER(^PS(55,PSOEDFN,"P","A",PSOPPQ,PSOPPQR))
- if 'PSOPPQR
- QUIT
- DO PAT
- if $DATA(^PSRX(PSOPPQR,0))&('$PIECE($GET(^PSRX(PSOPPQR,"OR1")),"^",2))&('$GET(PTFLAG))
- Begin DoDot:1
- +9 if '$PIECE($GET(^PSRX(PSOPPQR,0)),"^",2)
- QUIT
- +10 SET PSOEST=$SELECT($DATA(^PSRX(PSOPPQR,"STA")):$PIECE($GET(^PSRX(PSOPPQR,"STA")),"^"),1:$PIECE($GET(^PSRX(PSOPPQR,0)),"^",15))
- if PSOEST=10!(PSOEST=13)!(PSOEST=16)!(PSOEST=14)
- QUIT
- +11 if '$PIECE($GET(^PSRX(PSOPPQR,0)),"^",19)
- Begin DoDot:2
- +12 if '$PIECE($GET(^PSRX(PSOPPQR,"SIG")),"^",2)
- DO POP^PSOSIGNO(PSOPPQR)
- +13 IF $PIECE($GET(^PSRX(PSOPPQR,"OR1")),"^")']""
- IF +$GET(^PSDRUG(+$PIECE(^PSRX(PSOPPQR,0),"^",6),2))
- SET $PIECE(^PSRX(PSOPPQR,"OR1"),"^")=+$GET(^PSDRUG($PIECE(^PSRX(PSOPPQR,0),"^",6),2))
- +14 IF $GET(^PSRX(PSOPPQR,"SIG"))']""
- SET ^PSRX(PSOPPQR,"SIG")=$PIECE($GET(^PSRX(PSOPPQR,0)),"^",10)_"^"_0
- SET $PIECE(^PSRX(PSOPPQR,0),"^",10)=""
- +15 SET ^PSRX(PSOPPQR,"STA")=$PIECE($GET(^PSRX(PSOPPQR,0)),"^",15)
- SET $PIECE(^PSRX(PSOPPQR,0),"^",15)=""
- +16 SET PR=0
- FOR
- SET PR=$ORDER(^PSRX(PSOPPQR,"P",PR))
- if 'PR
- QUIT
- Begin DoDot:3
- +17 IF '$PIECE($GET(^PSRX(PSOPPQR,"P",PR,0)),"^")
- KILL ^PSRX(PSOPPQR,"P",PR,0)
- QUIT
- +18 SET ^PSRX("ADP",$EXTRACT($PIECE(^PSRX(PSOPPQR,"P",PR,0),"^"),1,7),PSOPPQR,PR)=""
- End DoDot:3
- +19 SET $PIECE(^PSRX(PSOPPQR,0),"^",19)=1
- End DoDot:2
- +20 if $GET(PSOEWRT)
- WRITE "."
- DO EN^PSOHLSN1(PSOPPQR,"ZC","")
- +21 if '$PIECE($GET(^PSRX(PSOPPQR,"OR1")),"^",2)
- QUIT
- +22 SET PSOEST=$PIECE($GET(^PSRX(PSOPPQR,"STA")),"^")
- +23 IF +$PIECE($GET(^PSRX(PSOPPQR,2)),"^",6)
- IF $PIECE($GET(^(2)),"^",6)<DT
- SET $PIECE(^PSRX(PSOPPQR,"STA"),"^")=11
- DO ECAN^PSOUTL(PSOPPQR)
- SET PSOEST=11
- +24 SET PSOERSTA=$SELECT(PSOEST=3:"OH",PSOEST=12:"OD",PSOEST=15:"OD",1:"SC")
- SET PSOPHSTA=$SELECT(PSOEST=0:"CM",PSOEST=1:"IP",PSOEST=4:"IP",PSOEST=5:"ZS",PSOEST=11:"ZE",1:"")
- +25 DO EN^PSOHLSN1(PSOPPQR,PSOERSTA,PSOPHSTA,"")
- End DoDot:1
- +26 SET $PIECE(^PS(55,PSOEDFN,0),"^",6)=2
- +27 ;W !,"Finished backfilling!",!
- +28 QUIT
- EN1(PSOEDFN,PSOEWRT) NEW PSOBCK
- +1 if '$GET(PSOEDFN)
- QUIT
- +2 SET X1=DT
- SET X2=-121
- DO C^%DTC
- SET PSOYEAR=X
- +3 IF $ORDER(^PS(55,PSOEDFN,"P","A",PSOYEAR))
- if '$DATA(^PS(55,PSOEDFN,0))
- DO ADD(PSOEDFN)
- DO EN2
- GOTO INPAT
- +4 if '$DATA(^PS(55,PSOEDFN,0))&($DATA(^PS(55,PSOEDFN)))
- DO ADD(PSOEDFN)
- if $DATA(^PS(55,PSOEDFN,0))
- SET $PIECE(^PS(55,PSOEDFN,0),"^",6)=2
- INPAT SET X="PSJUTL1"
- XECUTE ^%ZOSF("TEST")
- IF $TEST
- DO CONVERT^PSJUTL1(PSOEDFN,PSOEWRT)
- +1 QUIT
- UPD ;Update OERR if not done yet
- +1 NEW PSLOOP,PSOPPQR
- +2 FOR PSLOOP=0:0
- SET PSLOOP=$ORDER(^PS(55,PSOEDFN,"P","A",PSLOOP))
- if 'PSLOOP
- QUIT
- FOR PSOPPQR=0:0
- SET PSOPPQR=$ORDER(^PS(55,PSOEDFN,"P","A",PSLOOP,PSOPPQR))
- if 'PSOPPQR
- QUIT
- Begin DoDot:1
- +3 if $GET(^PSRX(PSOPPQR,0))=""!('$PIECE($GET(^PSRX(PSOPPQR,0)),"^",2))
- QUIT
- +4 if $PIECE(^PSRX(PSOPPQR,0),"^",19)
- QUIT
- +5 if '$PIECE($GET(^PSRX(PSOPPQR,"SIG")),"^",2)
- DO POP^PSOSIGNO(PSOPPQR)
- +6 IF $PIECE($GET(^PSRX(PSOPPQR,"OR1")),"^")']""
- IF +$GET(^PSDRUG(+$PIECE(^PSRX(PSOPPQR,0),"^",6),2))
- SET $PIECE(^PSRX(PSOPPQR,"OR1"),"^")=+$GET(^PSDRUG($PIECE(^PSRX(PSOPPQR,0),"^",6),2))
- +7 IF $GET(^PSRX(PSOPPQR,"SIG"))']""
- SET ^PSRX(PSOPPQR,"SIG")=$PIECE($GET(^PSRX(PSOPPQR,0)),"^",10)_"^"_0
- SET $PIECE(^PSRX(PSOPPQR,0),"^",10)=""
- +8 IF $GET(^PSRX(PSOPPQR,"STA"))']""
- SET ^PSRX(PSOPPQR,"STA")=$PIECE($GET(^PSRX(PSOPPQR,0)),"^",15)
- SET $PIECE(^PSRX(PSOPPQR,0),"^",15)=""
- +9 SET PRU=0
- FOR
- SET PRU=$ORDER(^PSRX(PSOPPQR,"P",PRU))
- if 'PRU
- QUIT
- Begin DoDot:2
- +10 IF '$PIECE($GET(^PSRX(PSOPPQR,"P",PRU,0)),"^")
- KILL ^PSRX(PSOPPQR,"P",PRU,0)
- QUIT
- +11 SET ^PSRX("ADP",$EXTRACT($PIECE(^PSRX(PSOPPQR,"P",PRU,0),"^"),1,7),PSOPPQR,PRU)=""
- End DoDot:2
- +12 SET $PIECE(^PSRX(PSOPPQR,0),"^",19)=1
- End DoDot:1
- +13 QUIT
- PAT ;Check for correct patient
- +1 SET PTFLAG=0
- +2 if PSOEDFN=$PIECE($GET(^PSRX(PSOPPQR,0)),"^",2)
- QUIT
- +3 SET PTFLAG=1
- +4 KILL ^PS(55,PSOEDFN,"P","A",PSOPPQ,PSOPPQR)
- +5 FOR III=0:0
- SET III=$ORDER(^PS(55,PSOEDFN,"P",III))
- if 'III
- QUIT
- IF $GET(^PS(55,PSOEDFN,"P",III,0))=PSOPPQR
- KILL ^PS(55,PSOEDFN,"P",III,0)
- +6 QUIT
- ADD(PATIEN) ;Add patient to 55 (0 node)
- +1 if $DATA(^PS(55,PATIEN,0))
- QUIT
- +2 NEW X,Y,DA,DIK
- +3 SET ^PS(55,PATIEN,0)=PATIEN
- KILL DIK
- SET DA=PATIEN
- SET DIK="^PS(55,"
- SET DIK(1)=.01
- DO EN^DIK
- +4 QUIT