- PSOATRFV ;BIR/MHA,KML - Automate VCC Refill request ;April 11,2022
- ;;7.0;OUTPATIENT PHARMACY;**642,679**;DEC 1997;Build 16
- ;Reference to ^PSSLOCK supported by DBIA 2789
- ;Reference ^PSDRUG supported by DBIA 221
- ;Reference ^PS(55 supported by DBIA 2228
- ;
- REF(PSORXN,PSOUSR,PSORFSRC,PSOITMG) ;process refill request
- ; Input:
- ; PSORX (required) - Prescription Number
- ; PSOUSR (optional) - User requesting refill
- ; PSORFSRC (optional) - the source system from which the REFILL
- ; request Originated (e.g., AUDIOCARE, VCC, CPRS, VSE)
- ; PSOITMG - error array
- N DFN,PSODFN,PSODTCUT,PSOITNS,PSOITDD,PSOITNF,PSOITF,DIV
- N PSOITP,PSOITR,PSOINST,PSOPAR,PSOPINST,PSOPRPAS,PSOPAR7,PSOPTPST
- N PSOSITE,PSOSNM,PSOSYS,PSORFN,PSOREA,PSOSTAT,PSOD,PSOS,DRG,DIVN
- N PSXSYS,RX,RX0,RXN,VA,ZZ,LC,XMY,PSORXN0,PSORXN2,PSORXN3,PSORXNS
- N DA,DIC,DIQ,DR,PSOFROM,PSORX,PSOX,PSOUTIL,SITE,PSOSD
- ;
- S (DIV,PSOSITE)=$P(^PSRX(PSORXN,2),"^",9)
- S (SITE,DA)=$P(^XMB(1,1,"XUS"),U,17),DIC="4",DIQ(0)="IE",DR=".01;99",DIQ="PSOUTIL" D EN^DIQ1
- S PSOINST=$G(PSOUTIL(4,SITE,99,"I"))
- S PSOPAR=$G(^PS(59,DIV,1)),PSORFN=$G(^PS(59,DIV,"RF")),PSOITNF=0
- S PSXSYS=+$O(^PSX(550,"C",""))_"^"_$G(PSOINST)_"^"_$G(PSOUTIL(4,SITE,.01,"E"))
- I $G(PSXSYS) D
- . K:($P($G(^PSX(550,+PSXSYS,0)),"^",2)'="A") PSXSYS
- . I $$VERSION^XPDUTL("PSO")<7.0 K PSXSYS
- S PSOSYS=$G(^PS(59.7,1,40.1))
- ;
- I '$D(^PSRX(PSORXN,0))!($P(^(0),U)="")!('$D(^(2)))!($P(^("STA"),U)=13) D Q
- . D ERR("Rx IEN "_PSORXN_" not in file (#52)/Incomplete/Deleted")
- S PSORXN0=^PSRX(PSORXN,0),PSORXN2=^(2),PSORXN3=^(3),PSORXNS=^("STA")
- S (DFN,PSODFN)=$P(PSORXN0,U,2),RXN=$P(PSORXN0,U),DRG=$P(PSORXN0,U,6)
- D GET^PSOPTPST
- I $G(PSOPTPST(2,PSODFN,.351))]"" D Q
- . D ERR("Patient Died on "_PSOPTPST(2,PSODFN,.351))
- D ICN^PSODPT(DFN)
- S PSOLOUD=1 D:$P($G(^PS(55,DFN,0)),U,6)'=2 EN^PSOHLUP(DFN) K PSOLOUD
- I '$P(PSOPAR,U,11),$G(^PSDRUG(DRG,"I"))]"",DT>$G(^("I")) D Q
- . D ERR("Drug is inactive for Rx # "_RXN_" cannot be refilled")
- I $G(PSOPTPST(2,PSODFN,.1))]"",'PSORFN D Q
- . D ERR("Patient is an Inpatient on Ward "_PSOPTPST(2,PSODFN,.1))
- I $G(PSOPTPST(2,PSODFN,148))="YES",'$P(PSORFN,U,2) D Q
- . D ERR("Patient is in a Contract Nursing Home")
- D CHKRF Q:PSOITNF ;Quit if RX not refillable
- ;
- ;more checks
- I $O(^PS(52.5,"B",PSORXN,0)),'$G(^PS(52.5,+$O(^PS(52.5,"B",PSORXN,0)),"P")) D Q
- . D ERR("Rx is in suspense and cannot be refilled")
- S PSOY=1+$$LSTRFL^PSOBPSU1(PSORXN)
- I PSOY>$P(PSORXN0,U,9) D Q
- . D ERR("Can't refill, no refills remaining")
- S (PSOITF,PSOX("NUMBER"))=PSOY
- S PSOX("RX0")=PSORXN0,PSOX("RX2")=PSORXN2,PSOX("RX3")=PSORXN3,PSOX("STA")=PSORXNS
- S DRG=$P(PSORXN0,U,6)
- N PSODEA,PSODAY,PSOCHECK
- S PSODEA=$P($G(^PSDRUG(DRG,0)),U,3)
- S PSODAY=$P(PSORXN0,U,8)
- S PSOCHECK=$$DEACHK^PSOUTLA1(PSORXN,PSODEA,PSODAY)
- I PSOCHECK=1 D ERR("Requested refill exceeds maximum allowable days supply for Rx.") Q ;*388
- I PSOCHECK=2 D ERR("Current drug DEA/SPECIAL HANDLING code does not allow refills.") Q ;*388
- D CHKDT Q:PSOITNF ;Quit if not refillable
- ;
- ; Titration Marked Rx
- I $$TITRX^PSOUTL(PSORXN)="t" D Q
- . D ERR("'Titration Rx' cannot be refilled.")
- ;
- ;ok to process refill
- D EN^PSOR52(.PSOX)
- ;add additional activity log comment to refill just added
- I PSOITF,$D(^PSRX(PSORXN,1,PSOITF,0)) D
- . S PSORFSRC=$G(PSORFSRC)
- . S ^PSRX(PSORXN,1,PSOITF,"RF1")=$S(PSORFSRC]"":PSORFSRC,1:"UNKNOWN")_"^"_$G(PSOUSR)
- . N AL,DONE,PSOFDA
- . S AL="",DONE=0
- . F S AL=$O(^PSRX(PSORXN,"A",AL),-1) Q:'AL D Q:DONE
- . . Q:$P(^PSRX(PSORXN,"A",AL,0),U,4)'=PSOITF
- . . S PSOFDA(52.34,"+3,"_AL_","_PSORXN_",",.01)=$S(PSORFSRC]"":PSORFSRC,1:"UNKNOWN")
- . . D UPDATE^DIE("","PSOFDA")
- . . S DONE=1
- Q
- ;
- CHKRF ;check prescription if still refillable
- S X2=-120,X1=DT D C^%DTC S PSODTCUT=X
- D ^PSOBUILD
- I '$G(PSOSD) D Q
- . D ERR("This patient has no prescriptions")
- S (PSOX,PSOY,PSOS)="",PSOX("STA")=PSORXNS
- F S PSOS=$O(PSOSD(PSOS)) Q:PSOS="" F S PSOX=$O(PSOSD(PSOS,PSOX)) Q:PSOX']"" D
- . I PSORXN=+PSOSD(PSOS,PSOX) S PSOY=PSOSD(PSOS,PSOX) I $P(PSOY,U,4)]"" D
- . . D ERR("Cannot refill Rx # "_RXN)
- . . S PSOREA=$P(PSOY,U,4),PSOSTAT=PSOX("STA")
- . . I PSOREA["Z" S:PSOSTAT=4 PSOSTAT=1 D Q
- . . . S PSOA=";"_PSOSTAT,PSOB=$P(^DD(52,100,0),U,3)
- . . . S PSOA=$F(PSOB,PSOA),PSOA=$P($E(PSOB,PSOA,999),";",1)
- . . . D ERR(" Rx is in "_$P(PSOA,":",2)_" status")
- . . . K PSOA,PSOB
- . . I PSOREA["M" D ERR("Drug no longer used by Outpatient Pharmacy") Q
- . . I PSOREA["B" D ERR("Narcotic Drug") Q
- . . I PSOREA["C" D ERR("Non-Renewable Drug") Q
- . . I PSOREA["D" D ERR("Non-Renewable Patient Status") Q
- . . I PSOREA["E" D ERR("Non-Verified Rx") Q
- . . I PSOREA["G",PSOREA'["B" D ERR("No more refills left")
- I PSOY="" D ERR("Cannot refill, Rx is DC/Exp. Later Rx may exist") D
- . S (PSOS,PSOX)="",PSOD=$P(^PSDRUG($P(PSORXN0,U,6),0),U)
- . N ZRX S ZRX=""
- . F S PSOS=$O(PSOSD(PSOS)) Q:PSOS="" D
- . . F S PSOX=$O(PSOSD(PSOS,PSOX)) Q:PSOX="" D
- . . . I PSOD=PSOX,+PSOSD(PSOS,PSOX) S ZRX=$P($G(^PSRX(+PSOSD(PSOS,PSOX),0)),U)
- . D ERR(ZRX)
- Q
- ;
- CHKDT ;check date on this refill request
- N X1,X2
- S PSOX("IRXN")=PSORXN
- S PSOX("MAIL/WINDOW")="M",PSOX("FLD")=2,PSOX("QS")="S"
- S PSOX("FIELD")=0,(PSORX("FILL DATE"),PSOX("FILL DATE"))=DT,PSOX("FLD")=1,X1=DT,X2=-180
- D C^%DTC S PSOX("ISSUE DATE")=X,PSOX("CLERK CODE")=DUZ
- S PSOX("STOP DATE")=$P(PSORXN2,U,6) D NEXT
- I PSOX("FILL DATE")<$P(PSORXN3,U,2) D SUSDATE^PSOUTIL(.PSOX)
- I PSOX("FILL DATE")>PSOX("STOP DATE") D Q
- . D ERR("Can't refill, Refill Date "_$$DSP(PSOX("FILL DATE")))
- . D ERR("is past Expiration Date "_$$DSP(PSOX("STOP DATE")))
- S PSOX("LAST REFILL DATE")=$P(PSORXN3,U,1)
- I PSOX("LAST REFILL DATE"),PSOX("FILL DATE")=PSOX("LAST REFILL DATE") D Q
- . D ERR("Can't refill, Fill Date already exists for "_$$DSP(PSOX("FILL DATE")))
- I PSOX("LAST REFILL DATE"),PSOX("FILL DATE")<PSOX("LAST REFILL DATE") D Q
- . D ERR("Can't refill, later Refill Date already exists for "_$$DSP(PSOX("LAST REFILL DATE")))
- Q
- ;
- NEXT ;
- S PSOX1=$P(PSORXN2,U,2)
- I '$O(^PSRX(PSORXN,1,0)) D Q
- . S $P(PSORXN3,U)=PSOX1,X1=PSOX1
- . S X2=$P(PSORXN0,U,8)-10\1
- . D C^%DTC
- . S:'$P(PSORXN3,U,8) $P(PSORXN3,U,2)=X K X
- S PSOY2=0
- F PSOY=0:0 S PSOY=$O(^PSRX(PSORXN,1,PSOY)) Q:'PSOY S PSOY1=PSOY,PSOY2=PSOY2+1
- S PSOY=^PSRX(PSORXN,1,PSOY1,0)
- S PSOX2=$P(PSOY,U)
- S $P(PSORXN3,U)=PSOX2,X1=PSOX2
- S X2=$P(PSORXN0,U,8)-10\1
- D C^%DTC S PSOY3=X
- S X1=PSOX1,X2=(PSOY2+1)*$P(PSORXN0,U,8)-10\1
- D C^%DTC S PSOY4=X
- S $P(PSORXN3,U,2)=$S(PSOY3<PSOY4:PSOY4,1:PSOY3)
- K X,X1,X2,PSOX1,PSOX2,PSOY,PSOY1,PSOY2,PSOY3,PSOY4
- Q
- ;
- DSP(X) ;
- Q:'X ""
- Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
- ;
- ERR(TXT) ;Build error text array
- ; add TXT to end of last line in array, if will fit, else
- ; add it as a new last line and indented 3.
- ; and set error flag
- N II S II=$O(PSOITMG(""),-1) S:'II II=1
- S PSOITNF=1
- I $L($G(PSOITMG(II)))+$L(TXT)>79 D
- . S PSOITMG(II+1)=" "_TXT
- E D
- . S PSOITMG(II)=$G(PSOITMG(II))_" "_TXT
- Q
- ;
- MAILMSG(DFN,RXN,ERRTXT) ;send alert via mailman msg to PSOAUTRF key holders
- N MDUZ,XMDUZ,XMTEXT,XMSUB,PTNAME,PTSSN,DIV,DIVN
- D DEM^VADPT
- S PTNAME=$P(VADM(1),"^"),PTSSN=$P($P(VADM(2),"^",2),"-",3) K VADM
- S DIV=$$RXSITE^PSOBPSUT(RXN,0),DIVN=$P($G(^PS(59,DIV,0)),"^")
- S MDUZ=0
- F S MDUZ=$O(^XUSEC("PSOAUTRF",MDUZ)) Q:MDUZ'>0 S XMY(MDUZ)=""
- S XMDUZ=.5,XMSUB=DIVN_" VCC AUTO REFILL - Not Processed List"
- S ERRTXT(.1)="VCC requested an Outpatient refill, but was not allowed for the below reason:"
- S ERRTXT(.2)=""
- S ERRTXT(.3)=" Patient: "_PTNAME_" ("_PTSSN_")"
- S ERRTXT(.4)=" Rx #: "_$$GET1^DIQ(52,RXN,.01)
- S ERRTXT(.5)=" Drug: "_$$GET1^DIQ(52,RXN,6)
- S ERRTXT(.6)=""
- S XMTEXT="ERRTXT(" N DIFROM
- D ^XMD
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOATRFV 7846 printed Jan 18, 2025@03:25:42 Page 2
- PSOATRFV ;BIR/MHA,KML - Automate VCC Refill request ;April 11,2022
- +1 ;;7.0;OUTPATIENT PHARMACY;**642,679**;DEC 1997;Build 16
- +2 ;Reference to ^PSSLOCK supported by DBIA 2789
- +3 ;Reference ^PSDRUG supported by DBIA 221
- +4 ;Reference ^PS(55 supported by DBIA 2228
- +5 ;
- REF(PSORXN,PSOUSR,PSORFSRC,PSOITMG) ;process refill request
- +1 ; Input:
- +2 ; PSORX (required) - Prescription Number
- +3 ; PSOUSR (optional) - User requesting refill
- +4 ; PSORFSRC (optional) - the source system from which the REFILL
- +5 ; request Originated (e.g., AUDIOCARE, VCC, CPRS, VSE)
- +6 ; PSOITMG - error array
- +7 NEW DFN,PSODFN,PSODTCUT,PSOITNS,PSOITDD,PSOITNF,PSOITF,DIV
- +8 NEW PSOITP,PSOITR,PSOINST,PSOPAR,PSOPINST,PSOPRPAS,PSOPAR7,PSOPTPST
- +9 NEW PSOSITE,PSOSNM,PSOSYS,PSORFN,PSOREA,PSOSTAT,PSOD,PSOS,DRG,DIVN
- +10 NEW PSXSYS,RX,RX0,RXN,VA,ZZ,LC,XMY,PSORXN0,PSORXN2,PSORXN3,PSORXNS
- +11 NEW DA,DIC,DIQ,DR,PSOFROM,PSORX,PSOX,PSOUTIL,SITE,PSOSD
- +12 ;
- +13 SET (DIV,PSOSITE)=$PIECE(^PSRX(PSORXN,2),"^",9)
- +14 SET (SITE,DA)=$PIECE(^XMB(1,1,"XUS"),U,17)
- SET DIC="4"
- SET DIQ(0)="IE"
- SET DR=".01;99"
- SET DIQ="PSOUTIL"
- DO EN^DIQ1
- +15 SET PSOINST=$GET(PSOUTIL(4,SITE,99,"I"))
- +16 SET PSOPAR=$GET(^PS(59,DIV,1))
- SET PSORFN=$GET(^PS(59,DIV,"RF"))
- SET PSOITNF=0
- +17 SET PSXSYS=+$ORDER(^PSX(550,"C",""))_"^"_$GET(PSOINST)_"^"_$GET(PSOUTIL(4,SITE,.01,"E"))
- +18 IF $GET(PSXSYS)
- Begin DoDot:1
- +19 if ($PIECE($GET(^PSX(550,+PSXSYS,0)),"^",2)'="A")
- KILL PSXSYS
- +20 IF $$VERSION^XPDUTL("PSO")<7.0
- KILL PSXSYS
- End DoDot:1
- +21 SET PSOSYS=$GET(^PS(59.7,1,40.1))
- +22 ;
- +23 IF '$DATA(^PSRX(PSORXN,0))!($PIECE(^(0),U)="")!('$DATA(^(2)))!($PIECE(^("STA"),U)=13)
- Begin DoDot:1
- +24 DO ERR("Rx IEN "_PSORXN_" not in file (#52)/Incomplete/Deleted")
- End DoDot:1
- QUIT
- +25 SET PSORXN0=^PSRX(PSORXN,0)
- SET PSORXN2=^(2)
- SET PSORXN3=^(3)
- SET PSORXNS=^("STA")
- +26 SET (DFN,PSODFN)=$PIECE(PSORXN0,U,2)
- SET RXN=$PIECE(PSORXN0,U)
- SET DRG=$PIECE(PSORXN0,U,6)
- +27 DO GET^PSOPTPST
- +28 IF $GET(PSOPTPST(2,PSODFN,.351))]""
- Begin DoDot:1
- +29 DO ERR("Patient Died on "_PSOPTPST(2,PSODFN,.351))
- End DoDot:1
- QUIT
- +30 DO ICN^PSODPT(DFN)
- +31 SET PSOLOUD=1
- if $PIECE($GET(^PS(55,DFN,0)),U,6)'=2
- DO EN^PSOHLUP(DFN)
- KILL PSOLOUD
- +32 IF '$PIECE(PSOPAR,U,11)
- IF $GET(^PSDRUG(DRG,"I"))]""
- IF DT>$GET(^("I"))
- Begin DoDot:1
- +33 DO ERR("Drug is inactive for Rx # "_RXN_" cannot be refilled")
- End DoDot:1
- QUIT
- +34 IF $GET(PSOPTPST(2,PSODFN,.1))]""
- IF 'PSORFN
- Begin DoDot:1
- +35 DO ERR("Patient is an Inpatient on Ward "_PSOPTPST(2,PSODFN,.1))
- End DoDot:1
- QUIT
- +36 IF $GET(PSOPTPST(2,PSODFN,148))="YES"
- IF '$PIECE(PSORFN,U,2)
- Begin DoDot:1
- +37 DO ERR("Patient is in a Contract Nursing Home")
- End DoDot:1
- QUIT
- +38 ;Quit if RX not refillable
- DO CHKRF
- if PSOITNF
- QUIT
- +39 ;
- +40 ;more checks
- +41 IF $ORDER(^PS(52.5,"B",PSORXN,0))
- IF '$GET(^PS(52.5,+$ORDER(^PS(52.5,"B",PSORXN,0)),"P"))
- Begin DoDot:1
- +42 DO ERR("Rx is in suspense and cannot be refilled")
- End DoDot:1
- QUIT
- +43 SET PSOY=1+$$LSTRFL^PSOBPSU1(PSORXN)
- +44 IF PSOY>$PIECE(PSORXN0,U,9)
- Begin DoDot:1
- +45 DO ERR("Can't refill, no refills remaining")
- End DoDot:1
- QUIT
- +46 SET (PSOITF,PSOX("NUMBER"))=PSOY
- +47 SET PSOX("RX0")=PSORXN0
- SET PSOX("RX2")=PSORXN2
- SET PSOX("RX3")=PSORXN3
- SET PSOX("STA")=PSORXNS
- +48 SET DRG=$PIECE(PSORXN0,U,6)
- +49 NEW PSODEA,PSODAY,PSOCHECK
- +50 SET PSODEA=$PIECE($GET(^PSDRUG(DRG,0)),U,3)
- +51 SET PSODAY=$PIECE(PSORXN0,U,8)
- +52 SET PSOCHECK=$$DEACHK^PSOUTLA1(PSORXN,PSODEA,PSODAY)
- +53 ;*388
- IF PSOCHECK=1
- DO ERR("Requested refill exceeds maximum allowable days supply for Rx.")
- QUIT
- +54 ;*388
- IF PSOCHECK=2
- DO ERR("Current drug DEA/SPECIAL HANDLING code does not allow refills.")
- QUIT
- +55 ;Quit if not refillable
- DO CHKDT
- if PSOITNF
- QUIT
- +56 ;
- +57 ; Titration Marked Rx
- +58 IF $$TITRX^PSOUTL(PSORXN)="t"
- Begin DoDot:1
- +59 DO ERR("'Titration Rx' cannot be refilled.")
- End DoDot:1
- QUIT
- +60 ;
- +61 ;ok to process refill
- +62 DO EN^PSOR52(.PSOX)
- +63 ;add additional activity log comment to refill just added
- +64 IF PSOITF
- IF $DATA(^PSRX(PSORXN,1,PSOITF,0))
- Begin DoDot:1
- +65 SET PSORFSRC=$GET(PSORFSRC)
- +66 SET ^PSRX(PSORXN,1,PSOITF,"RF1")=$SELECT(PSORFSRC]"":PSORFSRC,1:"UNKNOWN")_"^"_$GET(PSOUSR)
- +67 NEW AL,DONE,PSOFDA
- +68 SET AL=""
- SET DONE=0
- +69 FOR
- SET AL=$ORDER(^PSRX(PSORXN,"A",AL),-1)
- if 'AL
- QUIT
- Begin DoDot:2
- +70 if $PIECE(^PSRX(PSORXN,"A",AL,0),U,4)'=PSOITF
- QUIT
- +71 SET PSOFDA(52.34,"+3,"_AL_","_PSORXN_",",.01)=$SELECT(PSORFSRC]"":PSORFSRC,1:"UNKNOWN")
- +72 DO UPDATE^DIE("","PSOFDA")
- +73 SET DONE=1
- End DoDot:2
- if DONE
- QUIT
- End DoDot:1
- +74 QUIT
- +75 ;
- CHKRF ;check prescription if still refillable
- +1 SET X2=-120
- SET X1=DT
- DO C^%DTC
- SET PSODTCUT=X
- +2 DO ^PSOBUILD
- +3 IF '$GET(PSOSD)
- Begin DoDot:1
- +4 DO ERR("This patient has no prescriptions")
- End DoDot:1
- QUIT
- +5 SET (PSOX,PSOY,PSOS)=""
- SET PSOX("STA")=PSORXNS
- +6 FOR
- SET PSOS=$ORDER(PSOSD(PSOS))
- if PSOS=""
- QUIT
- FOR
- SET PSOX=$ORDER(PSOSD(PSOS,PSOX))
- if PSOX']""
- QUIT
- Begin DoDot:1
- +7 IF PSORXN=+PSOSD(PSOS,PSOX)
- SET PSOY=PSOSD(PSOS,PSOX)
- IF $PIECE(PSOY,U,4)]""
- Begin DoDot:2
- +8 DO ERR("Cannot refill Rx # "_RXN)
- +9 SET PSOREA=$PIECE(PSOY,U,4)
- SET PSOSTAT=PSOX("STA")
- +10 IF PSOREA["Z"
- if PSOSTAT=4
- SET PSOSTAT=1
- Begin DoDot:3
- +11 SET PSOA=";"_PSOSTAT
- SET PSOB=$PIECE(^DD(52,100,0),U,3)
- +12 SET PSOA=$FIND(PSOB,PSOA)
- SET PSOA=$PIECE($EXTRACT(PSOB,PSOA,999),";",1)
- +13 DO ERR(" Rx is in "_$PIECE(PSOA,":",2)_" status")
- +14 KILL PSOA,PSOB
- End DoDot:3
- QUIT
- +15 IF PSOREA["M"
- DO ERR("Drug no longer used by Outpatient Pharmacy")
- QUIT
- +16 IF PSOREA["B"
- DO ERR("Narcotic Drug")
- QUIT
- +17 IF PSOREA["C"
- DO ERR("Non-Renewable Drug")
- QUIT
- +18 IF PSOREA["D"
- DO ERR("Non-Renewable Patient Status")
- QUIT
- +19 IF PSOREA["E"
- DO ERR("Non-Verified Rx")
- QUIT
- +20 IF PSOREA["G"
- IF PSOREA'["B"
- DO ERR("No more refills left")
- End DoDot:2
- End DoDot:1
- +21 IF PSOY=""
- DO ERR("Cannot refill, Rx is DC/Exp. Later Rx may exist")
- Begin DoDot:1
- +22 SET (PSOS,PSOX)=""
- SET PSOD=$PIECE(^PSDRUG($PIECE(PSORXN0,U,6),0),U)
- +23 NEW ZRX
- SET ZRX=""
- +24 FOR
- SET PSOS=$ORDER(PSOSD(PSOS))
- if PSOS=""
- QUIT
- Begin DoDot:2
- +25 FOR
- SET PSOX=$ORDER(PSOSD(PSOS,PSOX))
- if PSOX=""
- QUIT
- Begin DoDot:3
- +26 IF PSOD=PSOX
- IF +PSOSD(PSOS,PSOX)
- SET ZRX=$PIECE($GET(^PSRX(+PSOSD(PSOS,PSOX),0)),U)
- End DoDot:3
- End DoDot:2
- +27 DO ERR(ZRX)
- End DoDot:1
- +28 QUIT
- +29 ;
- CHKDT ;check date on this refill request
- +1 NEW X1,X2
- +2 SET PSOX("IRXN")=PSORXN
- +3 SET PSOX("MAIL/WINDOW")="M"
- SET PSOX("FLD")=2
- SET PSOX("QS")="S"
- +4 SET PSOX("FIELD")=0
- SET (PSORX("FILL DATE"),PSOX("FILL DATE"))=DT
- SET PSOX("FLD")=1
- SET X1=DT
- SET X2=-180
- +5 DO C^%DTC
- SET PSOX("ISSUE DATE")=X
- SET PSOX("CLERK CODE")=DUZ
- +6 SET PSOX("STOP DATE")=$PIECE(PSORXN2,U,6)
- DO NEXT
- +7 IF PSOX("FILL DATE")<$PIECE(PSORXN3,U,2)
- DO SUSDATE^PSOUTIL(.PSOX)
- +8 IF PSOX("FILL DATE")>PSOX("STOP DATE")
- Begin DoDot:1
- +9 DO ERR("Can't refill, Refill Date "_$$DSP(PSOX("FILL DATE")))
- +10 DO ERR("is past Expiration Date "_$$DSP(PSOX("STOP DATE")))
- End DoDot:1
- QUIT
- +11 SET PSOX("LAST REFILL DATE")=$PIECE(PSORXN3,U,1)
- +12 IF PSOX("LAST REFILL DATE")
- IF PSOX("FILL DATE")=PSOX("LAST REFILL DATE")
- Begin DoDot:1
- +13 DO ERR("Can't refill, Fill Date already exists for "_$$DSP(PSOX("FILL DATE")))
- End DoDot:1
- QUIT
- +14 IF PSOX("LAST REFILL DATE")
- IF PSOX("FILL DATE")<PSOX("LAST REFILL DATE")
- Begin DoDot:1
- +15 DO ERR("Can't refill, later Refill Date already exists for "_$$DSP(PSOX("LAST REFILL DATE")))
- End DoDot:1
- QUIT
- +16 QUIT
- +17 ;
- NEXT ;
- +1 SET PSOX1=$PIECE(PSORXN2,U,2)
- +2 IF '$ORDER(^PSRX(PSORXN,1,0))
- Begin DoDot:1
- +3 SET $PIECE(PSORXN3,U)=PSOX1
- SET X1=PSOX1
- +4 SET X2=$PIECE(PSORXN0,U,8)-10\1
- +5 DO C^%DTC
- +6 if '$PIECE(PSORXN3,U,8)
- SET $PIECE(PSORXN3,U,2)=X
- KILL X
- End DoDot:1
- QUIT
- +7 SET PSOY2=0
- +8 FOR PSOY=0:0
- SET PSOY=$ORDER(^PSRX(PSORXN,1,PSOY))
- if 'PSOY
- QUIT
- SET PSOY1=PSOY
- SET PSOY2=PSOY2+1
- +9 SET PSOY=^PSRX(PSORXN,1,PSOY1,0)
- +10 SET PSOX2=$PIECE(PSOY,U)
- +11 SET $PIECE(PSORXN3,U)=PSOX2
- SET X1=PSOX2
- +12 SET X2=$PIECE(PSORXN0,U,8)-10\1
- +13 DO C^%DTC
- SET PSOY3=X
- +14 SET X1=PSOX1
- SET X2=(PSOY2+1)*$PIECE(PSORXN0,U,8)-10\1
- +15 DO C^%DTC
- SET PSOY4=X
- +16 SET $PIECE(PSORXN3,U,2)=$SELECT(PSOY3<PSOY4:PSOY4,1:PSOY3)
- +17 KILL X,X1,X2,PSOX1,PSOX2,PSOY,PSOY1,PSOY2,PSOY3,PSOY4
- +18 QUIT
- +19 ;
- DSP(X) ;
- +1 if 'X
- QUIT ""
- +2 QUIT $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
- +3 ;
- ERR(TXT) ;Build error text array
- +1 ; add TXT to end of last line in array, if will fit, else
- +2 ; add it as a new last line and indented 3.
- +3 ; and set error flag
- +4 NEW II
- SET II=$ORDER(PSOITMG(""),-1)
- if 'II
- SET II=1
- +5 SET PSOITNF=1
- +6 IF $LENGTH($GET(PSOITMG(II)))+$LENGTH(TXT)>79
- Begin DoDot:1
- +7 SET PSOITMG(II+1)=" "_TXT
- End DoDot:1
- +8 IF '$TEST
- Begin DoDot:1
- +9 SET PSOITMG(II)=$GET(PSOITMG(II))_" "_TXT
- End DoDot:1
- +10 QUIT
- +11 ;
- MAILMSG(DFN,RXN,ERRTXT) ;send alert via mailman msg to PSOAUTRF key holders
- +1 NEW MDUZ,XMDUZ,XMTEXT,XMSUB,PTNAME,PTSSN,DIV,DIVN
- +2 DO DEM^VADPT
- +3 SET PTNAME=$PIECE(VADM(1),"^")
- SET PTSSN=$PIECE($PIECE(VADM(2),"^",2),"-",3)
- KILL VADM
- +4 SET DIV=$$RXSITE^PSOBPSUT(RXN,0)
- SET DIVN=$PIECE($GET(^PS(59,DIV,0)),"^")
- +5 SET MDUZ=0
- +6 FOR
- SET MDUZ=$ORDER(^XUSEC("PSOAUTRF",MDUZ))
- if MDUZ'>0
- QUIT
- SET XMY(MDUZ)=""
- +7 SET XMDUZ=.5
- SET XMSUB=DIVN_" VCC AUTO REFILL - Not Processed List"
- +8 SET ERRTXT(.1)="VCC requested an Outpatient refill, but was not allowed for the below reason:"
- +9 SET ERRTXT(.2)=""
- +10 SET ERRTXT(.3)=" Patient: "_PTNAME_" ("_PTSSN_")"
- +11 SET ERRTXT(.4)=" Rx #: "_$$GET1^DIQ(52,RXN,.01)
- +12 SET ERRTXT(.5)=" Drug: "_$$GET1^DIQ(52,RXN,6)
- +13 SET ERRTXT(.6)=""
- +14 SET XMTEXT="ERRTXT("
- NEW DIFROM
- +15 DO ^XMD
- +16 QUIT