- PSOTRLBL ;BHAM ISC/AMC/SAB - MULTI RX REFILL REQUEST FORM ;08/24/17 10:11
- ;;7.0;OUTPATIENT PHARMACY;**19,92,107,110,326,441**;DEC 1997;Build 208
- ;External reference ^PS(59.7 supported by DBIA 694
- ;External reference to ^PS(55 supported by DBIA 2228
- CHK S PSDO=$O(^PS(52.5,"C",ZI,D0)),DFN=$P(^PS(52.5,D0,0),"^",3) I PSDO>0 S PSDFN=$P(^PS(52.5,PSDO,0),"^",3) Q:PSDFN=DFN
- G BUILD
- CHCK2 Q:'$G(PPL) S:'$D(PI) PI=0 Q:COPIES G:$G(PSOLAPPL)!($G(PSDFNFLG)) CHEDI I $P(PPL,",",PI+1)'="" Q
- CHEDI S $P(PSLN,"_",39)="" I $O(PSORX("PSOL",$G(PPL1))) S PPL1=$O(PSORX("PSOL",PPL1)),PPL=PSORX("PSOL",PPL1) F PI=0:1 G:$P(PPL,",",PI)="" INST S RX=$P(PPL,",",PI) D C^PSOLBL
- BUILD Q:'DFN S PS1=$G(^PS(59,PSOSITE,1)),PSOSITE7=$G(^("IB")),PSOSYS=$G(^PS(59.7,1,40.1)) I '$D(PSSPND) F PSRX=0:0 S PSRX=$O(RX(PSRX)) Q:'PSRX K RX(PSRX)
- F PSRX=0:0 S PSRX=$O(^PS(55,DFN,"P",PSRX)) Q:'PSRX D RZX
- G:'$O(RX(0))&($P($G(PSOPAR),"^",28)) EXIT
- S PSINF("STREET")=VAPA(1),PSINF("STREET 2")=VAPA(2),PSINF("CITY")=VAPA(4),PSINF("ZIP")=$S($G(VAPA(11))]"":$P($G(VAPA(11)),"^",2),1:$G(VAPA(6))),PSINF("STATE")=$P(VAPA(5),"^",2)
- S:VAPA(1)="" PSINF("STREET")="NO ADDRESS",(PSINF("CITY"),PSINF("STATE"),PSINF("ZIP"))="" S PSINF("NAME")=$P(^DPT(DFN,0),"^") D PID^VADPT S PSINF("SSAN")=VA("PID")
- S PSA=0,VASTREET=$P(^PS(59,PSOSITE,0),"^",2),VAADDR1=$P(^(0),"^")
- I $P(PSOSYS,"^",4),$D(^PS(59,+$P($G(PSOSYS),"^",4),0)) S PS=^PS(59,$P($G(PSOSYS),"^",4),0),VASTREET=$P(^PS(59,$P(PSOSYS,"^",4),0),"^",2),VAADDR1=$P(^PS(59,$P(PSOSYS,"^",4),0),"^")
- S COUNT=$S($G(PSOBARS)&($P(PSOPAR,"^",19)):3,1:10)
- I '$P(^PS(59,PSOSITE,1),"^",28) D DOCOLD Q
- ;NEW LABEL
- DOCNEW W ?54,PSINF("NAME")
- I PSINF("STREET 2")="" S PSINF("STREET 2")=PSINF("STREET"),PSINF("STREET")=""
- W !,?54,$G(VAPA(1)),!,?54,$G(ADDR(2))
- I $G(ADDR(3))="",$G(ADDR(4))="" G ADD
- I $G(ADDR(3))'="",$G(ADDR(4))="" W !,?54,$G(ADDR(3)) G ADD
- W !,?54,$G(ADDR(3)),!,?54,$G(ADDR(4))
- ADD I 'PSOORIG W !,?54,"Please check prescriptions to be refilled" ;441 PAPI
- I PSOORIG W !,?54,"Please check prescriptions to be filled/refilled"
- F J=1:1:COUNT S PSA=$O(RX(PSA)) S:'PSA J=J-1 Q:'PSA D SCRPTNEW
- W !,?54,"(",PSLN,")",!,?60,"PATIENT'S SIGNATURE ",$E(DT,4,5),"/",$E(DT,6,7),"/",($E(DT,1,3)+1700)
- DOCEND W @IOF I PSA,$O(RX(PSA)) G DOCNEW
- INST ;
- EXIT K PSINF,AMC,PSA,PSDFN,PSDO,PSDT2,PSRFL,PSRX,PSLN,PSRXX,PSSS,PSST,PSOCR,DIWL,DIWR,DIWF,PSO9 Q
- SCRPTNEW W !,?54,"(___) ",$$ZZ^PSOSUTL(PSA) K ZDRUG
- W !,?60,$P(RX(PSA),"^",2)," " D DTCONNW W ?64,"Expires ",PSDT2," Rx# ",$P(^PSRX(PSA,0),"^") K TN
- I $G(PSOBARS),$P($G(PSOPAR),"^",19) S X="S",X2=PSOINST_"-"_PSA W !,?60 S X1=$X W @PSOBAR1,X2,@PSOBAR0
- Q
- DTCONNW S PSDT2=$P(RX(PSA),"^"),PSDT2=$E(PSDT2,4,5)_"/"_$E(PSDT2,6,7)_"/"_($E(PSDT2,1,3)+1700) Q
- ;OLD LABEL
- DOCOLD W $C(13) S $X=0 W ?38,PSINF("SSAN")," FEE: " I $P($G(PSOPAR),"^",17) W $P($G(^DPT(DFN,.17)),"^",2)
- W ?63,"REFILL REQUEST: PLEASE CHECK PRESCRIPTIONS TO BE REFILLED",!?38,PSINF("NAME"),?79,"YOUR SIGNATURE IS REQUIRED"
- W !?38,PSINF("STREET"),?60,"REFILLS" W:PSINF("STREET 2")]"" !?38,PSINF("STREET 2") W !?38,PSINF("CITY"),?59,"REMAINING EXPIRES",!?38,PSINF("STATE")," ",PSINF("ZIP")
- F J=1:1:COUNT S PSA=$O(RX(PSA)) S:'PSA J=J-1 Q:'PSA D SCRPTOLD
- W !!! W ?40,"(",PSLN,")"," PATIENT'S SIGNATURE ",$E(DT,4,5),"/",$E(DT,6,7),"/",($E(DT,1,3)+1700)
- W @IOF I PSA,$O(RX(PSA)) G DOCOLD
- K PSINF,AMC,PSA,PSDFN,PSDO,PSDT2,PSRFL,PSRX,PSRXX,PSSS,PSST,PSLN Q
- SCRPTOLD W !?56,"(____) ",$P(RX(PSA),"^",2)," " D DTCONOD W ?67,PSDT2," ",$P(^PSRX(PSA,0),"^")
- W ?85,$$ZZ^PSOSUTL(PSA) K ZDRUG
- I $G(PSOBARS),+$P($G(PSOPAR),"^",19) S X="S",X2=PSOINST_"-"_PSA W !,?80 S X1=$X W @PSOBAR1,X2,@PSOBAR0
- Q
- DTCONOD S PSDT2=$P(RX(PSA),"^"),PSDT2=$E(PSDT2,4,5)_"/"_$E(PSDT2,6,7)_"/"_($E(PSDT2,1,3)+1700) Q
- REFILL F AMC=0:0 S AMC=$O(^PSRX(PSRXX,1,AMC)) Q:'AMC S PSRFL=PSRFL-1
- I PSRFL>0 S X1=DT,X2=$P(^PSRX(PSRXX,0),"^",8)-10 D C^%DTC I X'<$P(^(2),"^",6) S PSRFL=0
- Q
- RZX ;
- S PSOORIG=0 ;441 PAPI
- S PSRXX=+^PS(55,DFN,"P",PSRX,0) I $D(^PSRX(PSRXX,0)) D
- .N EXPDT
- .S EXPDT=$P(^PSRX(PSRXX,2),"^",6) I EXPDT'>DT Q
- .S PSRFL=$P(^PSRX(PSRXX,0),"^",9) D:$D(^PSRX(PSRXX,1))&PSRFL REFILL
- .I +PSRFL=0,$G(^PSRX(PSRXX,"PARK")),$P($G(^PSRX(PSRXX,"STA")),"^")=0 D CHKLBL^PSOPRKA(PSRXX,0) I 'LBLP S RX(PSRXX)=EXPDT_"^"_PSRFL,PSOORIG=1
- .I PSRFL>0,$P($G(^PSRX(PSRXX,"STA")),"^")<10,134'[$E(+$P($G(^("STA")),"^")) S RX(PSRXX)=EXPDT_"^"_PSRFL
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOTRLBL 4411 printed Feb 19, 2025@00:02:28 Page 2
- PSOTRLBL ;BHAM ISC/AMC/SAB - MULTI RX REFILL REQUEST FORM ;08/24/17 10:11
- +1 ;;7.0;OUTPATIENT PHARMACY;**19,92,107,110,326,441**;DEC 1997;Build 208
- +2 ;External reference ^PS(59.7 supported by DBIA 694
- +3 ;External reference to ^PS(55 supported by DBIA 2228
- CHK SET PSDO=$ORDER(^PS(52.5,"C",ZI,D0))
- SET DFN=$PIECE(^PS(52.5,D0,0),"^",3)
- IF PSDO>0
- SET PSDFN=$PIECE(^PS(52.5,PSDO,0),"^",3)
- if PSDFN=DFN
- QUIT
- +1 GOTO BUILD
- CHCK2 if '$GET(PPL)
- QUIT
- if '$DATA(PI)
- SET PI=0
- if COPIES
- QUIT
- if $GET(PSOLAPPL)!($GET(PSDFNFLG))
- GOTO CHEDI
- IF $PIECE(PPL,",",PI+1)'=""
- QUIT
- CHEDI SET $PIECE(PSLN,"_",39)=""
- IF $ORDER(PSORX("PSOL",$GET(PPL1)))
- SET PPL1=$ORDER(PSORX("PSOL",PPL1))
- SET PPL=PSORX("PSOL",PPL1)
- FOR PI=0:1
- if $PIECE(PPL,",",PI)=""
- GOTO INST
- SET RX=$PIECE(PPL,",",PI)
- DO C^PSOLBL
- BUILD if 'DFN
- QUIT
- SET PS1=$GET(^PS(59,PSOSITE,1))
- SET PSOSITE7=$GET(^("IB"))
- SET PSOSYS=$GET(^PS(59.7,1,40.1))
- IF '$DATA(PSSPND)
- FOR PSRX=0:0
- SET PSRX=$ORDER(RX(PSRX))
- if 'PSRX
- QUIT
- KILL RX(PSRX)
- +1 FOR PSRX=0:0
- SET PSRX=$ORDER(^PS(55,DFN,"P",PSRX))
- if 'PSRX
- QUIT
- DO RZX
- +2 if '$ORDER(RX(0))&($PIECE($GET(PSOPAR),"^",28))
- GOTO EXIT
- +3 SET PSINF("STREET")=VAPA(1)
- SET PSINF("STREET 2")=VAPA(2)
- SET PSINF("CITY")=VAPA(4)
- SET PSINF("ZIP")=$SELECT($GET(VAPA(11))]"":$PIECE($GET(VAPA(11)),"^",2),1:$GET(VAPA(6)))
- SET PSINF("STATE")=$PIECE(VAPA(5),"^",2)
- +4 if VAPA(1)=""
- SET PSINF("STREET")="NO ADDRESS"
- SET (PSINF("CITY"),PSINF("STATE"),PSINF("ZIP"))=""
- SET PSINF("NAME")=$PIECE(^DPT(DFN,0),"^")
- DO PID^VADPT
- SET PSINF("SSAN")=VA("PID")
- +5 SET PSA=0
- SET VASTREET=$PIECE(^PS(59,PSOSITE,0),"^",2)
- SET VAADDR1=$PIECE(^(0),"^")
- +6 IF $PIECE(PSOSYS,"^",4)
- IF $DATA(^PS(59,+$PIECE($GET(PSOSYS),"^",4),0))
- SET PS=^PS(59,$PIECE($GET(PSOSYS),"^",4),0)
- SET VASTREET=$PIECE(^PS(59,$PIECE(PSOSYS,"^",4),0),"^",2)
- SET VAADDR1=$PIECE(^PS(59,$PIECE(PSOSYS,"^",4),0),"^")
- +7 SET COUNT=$SELECT($GET(PSOBARS)&($PIECE(PSOPAR,"^",19)):3,1:10)
- +8 IF '$PIECE(^PS(59,PSOSITE,1),"^",28)
- DO DOCOLD
- QUIT
- +9 ;NEW LABEL
- DOCNEW WRITE ?54,PSINF("NAME")
- +1 IF PSINF("STREET 2")=""
- SET PSINF("STREET 2")=PSINF("STREET")
- SET PSINF("STREET")=""
- +2 WRITE !,?54,$GET(VAPA(1)),!,?54,$GET(ADDR(2))
- +3 IF $GET(ADDR(3))=""
- IF $GET(ADDR(4))=""
- GOTO ADD
- +4 IF $GET(ADDR(3))'=""
- IF $GET(ADDR(4))=""
- WRITE !,?54,$GET(ADDR(3))
- GOTO ADD
- +5 WRITE !,?54,$GET(ADDR(3)),!,?54,$GET(ADDR(4))
- ADD ;441 PAPI
- IF 'PSOORIG
- WRITE !,?54,"Please check prescriptions to be refilled"
- +1 IF PSOORIG
- WRITE !,?54,"Please check prescriptions to be filled/refilled"
- +2 FOR J=1:1:COUNT
- SET PSA=$ORDER(RX(PSA))
- if 'PSA
- SET J=J-1
- if 'PSA
- QUIT
- DO SCRPTNEW
- +3 WRITE !,?54,"(",PSLN,")",!,?60,"PATIENT'S SIGNATURE ",$EXTRACT(DT,4,5),"/",$EXTRACT(DT,6,7),"/",($EXTRACT(DT,1,3)+1700)
- DOCEND WRITE @IOF
- IF PSA
- IF $ORDER(RX(PSA))
- GOTO DOCNEW
- INST ;
- EXIT KILL PSINF,AMC,PSA,PSDFN,PSDO,PSDT2,PSRFL,PSRX,PSLN,PSRXX,PSSS,PSST,PSOCR,DIWL,DIWR,DIWF,PSO9
- QUIT
- SCRPTNEW WRITE !,?54,"(___) ",$$ZZ^PSOSUTL(PSA)
- KILL ZDRUG
- +1 WRITE !,?60,$PIECE(RX(PSA),"^",2)," "
- DO DTCONNW
- WRITE ?64,"Expires ",PSDT2," Rx# ",$PIECE(^PSRX(PSA,0),"^")
- KILL TN
- +2 IF $GET(PSOBARS)
- IF $PIECE($GET(PSOPAR),"^",19)
- SET X="S"
- SET X2=PSOINST_"-"_PSA
- WRITE !,?60
- SET X1=$X
- WRITE @PSOBAR1,X2,@PSOBAR0
- +3 QUIT
- DTCONNW SET PSDT2=$PIECE(RX(PSA),"^")
- SET PSDT2=$EXTRACT(PSDT2,4,5)_"/"_$EXTRACT(PSDT2,6,7)_"/"_($EXTRACT(PSDT2,1,3)+1700)
- QUIT
- +1 ;OLD LABEL
- DOCOLD WRITE $CHAR(13)
- SET $X=0
- WRITE ?38,PSINF("SSAN")," FEE: "
- IF $PIECE($GET(PSOPAR),"^",17)
- WRITE $PIECE($GET(^DPT(DFN,.17)),"^",2)
- +1 WRITE ?63,"REFILL REQUEST: PLEASE CHECK PRESCRIPTIONS TO BE REFILLED",!?38,PSINF("NAME"),?79,"YOUR SIGNATURE IS REQUIRED"
- +2 WRITE !?38,PSINF("STREET"),?60,"REFILLS"
- if PSINF("STREET 2")]""
- WRITE !?38,PSINF("STREET 2")
- WRITE !?38,PSINF("CITY"),?59,"REMAINING EXPIRES",!?38,PSINF("STATE")," ",PSINF("ZIP")
- +3 FOR J=1:1:COUNT
- SET PSA=$ORDER(RX(PSA))
- if 'PSA
- SET J=J-1
- if 'PSA
- QUIT
- DO SCRPTOLD
- +4 WRITE !!!
- WRITE ?40,"(",PSLN,")"," PATIENT'S SIGNATURE ",$EXTRACT(DT,4,5),"/",$EXTRACT(DT,6,7),"/",($EXTRACT(DT,1,3)+1700)
- +5 WRITE @IOF
- IF PSA
- IF $ORDER(RX(PSA))
- GOTO DOCOLD
- +6 KILL PSINF,AMC,PSA,PSDFN,PSDO,PSDT2,PSRFL,PSRX,PSRXX,PSSS,PSST,PSLN
- QUIT
- SCRPTOLD WRITE !?56,"(____) ",$PIECE(RX(PSA),"^",2)," "
- DO DTCONOD
- WRITE ?67,PSDT2," ",$PIECE(^PSRX(PSA,0),"^")
- +1 WRITE ?85,$$ZZ^PSOSUTL(PSA)
- KILL ZDRUG
- +2 IF $GET(PSOBARS)
- IF +$PIECE($GET(PSOPAR),"^",19)
- SET X="S"
- SET X2=PSOINST_"-"_PSA
- WRITE !,?80
- SET X1=$X
- WRITE @PSOBAR1,X2,@PSOBAR0
- +3 QUIT
- DTCONOD SET PSDT2=$PIECE(RX(PSA),"^")
- SET PSDT2=$EXTRACT(PSDT2,4,5)_"/"_$EXTRACT(PSDT2,6,7)_"/"_($EXTRACT(PSDT2,1,3)+1700)
- QUIT
- REFILL FOR AMC=0:0
- SET AMC=$ORDER(^PSRX(PSRXX,1,AMC))
- if 'AMC
- QUIT
- SET PSRFL=PSRFL-1
- +1 IF PSRFL>0
- SET X1=DT
- SET X2=$PIECE(^PSRX(PSRXX,0),"^",8)-10
- DO C^%DTC
- IF X'<$PIECE(^(2),"^",6)
- SET PSRFL=0
- +2 QUIT
- RZX ;
- +1 ;441 PAPI
- SET PSOORIG=0
- +2 SET PSRXX=+^PS(55,DFN,"P",PSRX,0)
- IF $DATA(^PSRX(PSRXX,0))
- Begin DoDot:1
- +3 NEW EXPDT
- +4 SET EXPDT=$PIECE(^PSRX(PSRXX,2),"^",6)
- IF EXPDT'>DT
- QUIT
- +5 SET PSRFL=$PIECE(^PSRX(PSRXX,0),"^",9)
- if $DATA(^PSRX(PSRXX,1))&PSRFL
- DO REFILL
- +6 IF +PSRFL=0
- IF $GET(^PSRX(PSRXX,"PARK"))
- IF $PIECE($GET(^PSRX(PSRXX,"STA")),"^")=0
- DO CHKLBL^PSOPRKA(PSRXX,0)
- IF 'LBLP
- SET RX(PSRXX)=EXPDT_"^"_PSRFL
- SET PSOORIG=1
- +7 IF PSRFL>0
- IF $PIECE($GET(^PSRX(PSRXX,"STA")),"^")<10
- IF 134'[$EXTRACT(+$PIECE($GET(^("STA")),"^"))
- SET RX(PSRXX)=EXPDT_"^"_PSRFL
- End DoDot:1
- +8 QUIT