PSOLLL7 ;BHAM/JLC - LASER LABEL MULTI RX REFILL REQUEST FORM ;29-May-2012 14:53;PLS
;;7.0;OUTPATIENT PHARMACY;**120,161,200,326,1015**;DEC 1997;Build 62
;
;Reference to ^PS(59.7 supported by DBIA 694
;Reference to ^PS(55 supported by DBIA 2228
;Read-only reference to %ZIS(2 supported by DBIA 3435
;
; Modified - IHS/CIA/PLS - 03/05/04
EN D MAIL
I $G(PSOIO("PII"))]"" X PSOIO("PII")
S T="Use the adhesive label above to mail prescription" D PRINT(T)
S T="documents to your pharmacy." D PRINT(T)
REFILL 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)
S BLNKLIN="",$P(BLNKLIN,"_",45)="_"
F PSRX=0:0 S PSRX=$O(^PS(55,DFN,"P",PSRX)) Q:'PSRX D RZX
;NEW LABEL
S PSOX=0
DOCNEW I $G(PSOIO("RPI"))]"" X PSOIO("RPI")
S PSOYI=PSOTYI,PSOX=PSOLX,ORIGY=PSOY
D HDR S PSA=0
F J=1:1 S PSA=$O(RX(PSA)) Q:'PSA D SCRPTNEW
I $O(RX(0))="" G EXIT
I PSOY=ORIGY G EXIT
S PSOYI=PSOSYI,T=BLNKLIN D PRINT(T) S PSOYI=PSOTYI
S PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:"")
S T="Patient's Signature & Date "_$P(PS,"^",6)_" "_PSONOW D PRINT(T)
EXIT K PSINF,AMC,PSA,PSDFN,PSDO,PSDT2,PSRFL,PSRX,PSLN,PSRXX,PSSS,PSST,PSOCR,DIWL,DIWR,DIWF,PSO9
I $D(ZTQUEUED) S ZTREQ="@"
Q
SCRPTNEW S T="____"_$$ZZ^PSOSUTL(PSA) K ZDRUG D PRINT(T) S PSOYI=PSOTYI
D DTCONNW
S PSOYI=PSOTYI,OPSOX=PSOX,PSOX=PSOX+PSOXI,T="Refills "_$P(RX(PSA),"^",2)_" Exp "_PSDT2_" Rx# "_$P(^PSRX(PSA,0),"^") K TN D PRINT(T)
S PSOYI=PSOBYI
; IHS/CIA/PLS - 03/08/04 - Changed to use barcode output routine
;I $G(PSOIO("SBT"))]"" X PSOIO("SBT")
S X2=PSOINST_"-"_PSA,PSOX=PSOX+PSOXI
;W X2
W $$BC^CIAUBC28(X2,0,50,PSOX,PSOY)
I $G(PSOIO("EBT"))]"" X PSOIO("EBT")
S PSOX=OPSOX
I PSOY>PSOYM D D:$O(RX(PSA)) HDR Q
.S T=BLNKLIN,PSOYI=PSOSYI D PRINT(T) S PSOYI=PSOTYI
.S T="Patient's Signature & Date "_$P(PS,"^",6)_" "_PSONOW D PRINT(T)
.S PSOY=ORIGY,PSOYI=PSOTYI
.I PSOX=PSORX S PSOX=PSOLX W @IOF Q
.S PSOX=PSORX
Q
DTCONNW S PSDT2=$P(RX(PSA),"^"),PSDT2=$E(PSDT2,4,5)_"/"_$E(PSDT2,6,7)_"/"_($E(PSDT2,1,3)+1700) Q
RFILL2 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 PSRXX=+^PS(55,DFN,"P",PSRX,0)
I $D(^PSRX(PSRXX,0)) S PSRFL=$P(^(0),"^",9) D:$D(^(1))&PSRFL RFILL2 I PSRFL>0,$P($G(^PSRX(PSRXX,"STA")),"^")<10,134'[$E(+$P($G(^("STA")),"^")),$P(^(2),"^",6)>DT S RX(PSRXX)=$P(^(2),"^",6)_"^"_PSRFL
Q
HDR S T=PNM D PRINT(T)
D ADD^VADPT
I $G(VAPA(1))="" G HDR5
F I=1:1:3 I $G(VAPA(I))]"" S T=VAPA(I) D PRINT(T)
S A=+$G(VAPA(5)) I A S A=$S($D(^DIC(5,A,0)):$P(^(0),"^",2),1:"UNKNOWN")
S B=$G(VAPA(4))_", "_A_" "_$S($G(VAPA(11)):$P(VAPA(11),"^",2),1:$G(VAPA(6)))
S T=B D PRINT(T)
HDR5 I $O(RX(0))="" D S PSOY=PSOY+PSOYI Q
.S PSOY=PSOY+PSOYI,T="You have no refillable prescriptions as of "_PSONOW_"." D PRINT(T)
.S T="Please contact your provider if you need new prescriptions." D PRINT(T)
.I '$D(PSOINST) D SITE
.S PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:"")
.S OPSOX=PSOX,OPSOY=PSOY,T=$P(PS,"^",6) S PSOX=2300,PSOY=3900 D PRINT(T) S PSOX=OPSOX,PSOY=OPSOY
ADD S PSOY=PSOY+PSOYI,T="Please check prescriptions to be refilled, sign the form, then" D PRINT(T)
S T="mail or return to your pharmacy." D PRINT(T) S PSOY=PSOY+PSOYI
Q
MAIL ;PRINT MAILING ADHESIVE LABEL
S PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:"")
I $P(PSOSYS,"^",4),$D(^PS(59,+$P($G(PSOSYS),"^",4),0)) S PS=^PS(59,$P($G(PSOSYS),"^",4),0)
S VAADDR1=$P(PS,"^"),VASTREET=$P(PS,"^",2),STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UNKNOWN")
S PSZIP=$P(PS,"^",5),PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
I $G(PSOIO("MLI"))]"" X PSOIO("MLI")
I $G(PSOIO("PSOFONT"))]"" X PSOIO("PSOFONT")
; IHS/CIA/PLS - 03/05/04 - Changed from 119 to Pharmacy
;S TEXT="Attn: (119)" D PRINT(TEXT)
S TEXT="Attn: Pharmacy" D PRINT(TEXT)
S TEXT=VAADDR1 D PRINT(TEXT)
S TEXT=$G(VASTREET) D PRINT(TEXT)
S TEXT=$P(PS,"^",7)_", "_$G(STATE)_" "_$G(PSOHZIP) D PRINT(TEXT)
Q
PRINT(T) ;
I $G(PSOIO(PSOFONT))]"" X PSOIO(PSOFONT)
I $G(PSOIO("ST"))]"" X PSOIO("ST")
W T,!
I $G(PSOIO("ET"))]"" X PSOIO("ET")
Q
QUEUE ; ENTRY POINT TO PRINT STAND-ALONE MULTI-RX FORM
S SAVDFN=$D(DFN) ; DFN SET IF COMING FROM HIDDEN ACTION
I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) Q
I '$G(PSOSYS) S PSOSYS=$G(^PS(59.7,1,40.1))
I '$D(PSOINST) D SITE
W !
I $D(DFN) G GETPT2
GETPT S DIC("A")="Enter patient to reprint Multi-Rx refill form for: ",DIC(0)="QEAM" D EN^PSOPATLK S Y=PSOPTLK I Y<0!("^"[X) K PSOPTLK,DIC Q
S DFN=$P(Y,"^")
GETPT2 D DEM^VADPT S PNM=VADM(1)
I $P(VADM(6),"^",2)]"" D G GETPT
.W $C(7),!!,PNM_" Died "_$P(VADM(6),"^",2)_".",!
Q1 W ! K POP,ZTSK S %ZIS("B")="",%ZIS="MNQ",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS S PSLION=ION K %ZIS("A")
I $G(POP) Q
I $G(IOST(0)),'$D(^%ZIS(2,IOST(0),55,"B","LL")) W !,"Must specify a laser labels printer for Multi-Rx form." G Q1
I '$G(IOST(0)) W !,"Nothing queued to print." H 1 Q
D 6^VADPT,PID^VADPT6 S SSNP=""
D NOW^%DTC S Y=$P(%,"."),PSOFNOW=% X ^DD("DD") S PSONOW=Y
F G="DFN","PNM","PSOPAR","PSOSITE","SSNP","PSONOW","PSOSYS","PSOINST" S:$D(@G) ZTSAVE(G)=""
S ZTRTN="DQ^PSOLLL7",ZTIO=PSLION,ZTDESC="Outpatient Pharmacy Multi-Rx print",ZTDTH=$H,PDUZ=DUZ
D ^%ZISC,^%ZTLOAD W:$D(ZTSK) !!,"Multi-Rx form queued to print",!! H 1 K G
I $G(SAVDFN)=0 K DFN,SAVDFN
Q
DQ N PSOBIO S (I,PSOIO)=0 F S I=$O(^%ZIS(2,IOST(0),55,I)) Q:'I S X0=$G(^(I,0)) I X0]"" S PSOIO($P(X0,"^"))=^(1),PSOIO=1
I $G(PSOIO("LLI"))]"" X PSOIO("LLI")
G EN
SITE ;
K ^UTILITY("DIQ1",$J) S DA=$P($$SITE^VASITE(),"^")
I $G(DA)>0 S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIC
I '$D(PSOINST) S PSOINST=""
Q
PSOLLL7 ;BHAM/JLC - LASER LABEL MULTI RX REFILL REQUEST FORM ;29-May-2012 14:53;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**120,161,200,326,1015**;DEC 1997;Build 62
+2 ;
+3 ;Reference to ^PS(59.7 supported by DBIA 694
+4 ;Reference to ^PS(55 supported by DBIA 2228
+5 ;Read-only reference to %ZIS(2 supported by DBIA 3435
+6 ;
+7 ; Modified - IHS/CIA/PLS - 03/05/04
EN DO MAIL
+1 IF $GET(PSOIO("PII"))]""
XECUTE PSOIO("PII")
+2 SET T="Use the adhesive label above to mail prescription"
DO PRINT(T)
+3 SET T="documents to your pharmacy."
DO PRINT(T)
REFILL IF 'DFN
QUIT
SET PS1=$GET(^PS(59,PSOSITE,1))
SET PSOSITE7=$GET(^("IB"))
SET PSOSYS=$GET(^PS(59.7,1,40.1))
+1 IF '$DATA(PSSPND)
FOR PSRX=0:0
SET PSRX=$ORDER(RX(PSRX))
IF 'PSRX
QUIT
KILL RX(PSRX)
+2 SET BLNKLIN=""
SET $PIECE(BLNKLIN,"_",45)="_"
+3 FOR PSRX=0:0
SET PSRX=$ORDER(^PS(55,DFN,"P",PSRX))
IF 'PSRX
QUIT
DO RZX
+4 ;NEW LABEL
+5 SET PSOX=0
DOCNEW IF $GET(PSOIO("RPI"))]""
XECUTE PSOIO("RPI")
+1 SET PSOYI=PSOTYI
SET PSOX=PSOLX
SET ORIGY=PSOY
+2 DO HDR
SET PSA=0
+3 FOR J=1:1
SET PSA=$ORDER(RX(PSA))
IF 'PSA
QUIT
DO SCRPTNEW
+4 IF $ORDER(RX(0))=""
GOTO EXIT
+5 IF PSOY=ORIGY
GOTO EXIT
+6 SET PSOYI=PSOSYI
SET T=BLNKLIN
DO PRINT(T)
SET PSOYI=PSOTYI
+7 SET PS=$SELECT($DATA(^PS(59,PSOSITE,0)):^(0),1:"")
+8 SET T="Patient's Signature & Date "_$PIECE(PS,"^",6)_" "_PSONOW
DO PRINT(T)
EXIT KILL PSINF,AMC,PSA,PSDFN,PSDO,PSDT2,PSRFL,PSRX,PSLN,PSRXX,PSSS,PSST,PSOCR,DIWL,DIWR,DIWF,PSO9
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
SCRPTNEW SET T="____"_$$ZZ^PSOSUTL(PSA)
KILL ZDRUG
DO PRINT(T)
SET PSOYI=PSOTYI
+1 DO DTCONNW
+2 SET PSOYI=PSOTYI
SET OPSOX=PSOX
SET PSOX=PSOX+PSOXI
SET T="Refills "_$PIECE(RX(PSA),"^",2)_" Exp "_PSDT2_" Rx# "_$PIECE(^PSRX(PSA,0),"^")
KILL TN
DO PRINT(T)
+3 SET PSOYI=PSOBYI
+4 ; IHS/CIA/PLS - 03/08/04 - Changed to use barcode output routine
+5 ;I $G(PSOIO("SBT"))]"" X PSOIO("SBT")
+6 SET X2=PSOINST_"-"_PSA
SET PSOX=PSOX+PSOXI
+7 ;W X2
+8 WRITE $$BC^CIAUBC28(X2,0,50,PSOX,PSOY)
+9 IF $GET(PSOIO("EBT"))]""
XECUTE PSOIO("EBT")
+10 SET PSOX=OPSOX
+11 IF PSOY>PSOYM
Begin DoDot:1
+12 SET T=BLNKLIN
SET PSOYI=PSOSYI
DO PRINT(T)
SET PSOYI=PSOTYI
+13 SET T="Patient's Signature & Date "_$PIECE(PS,"^",6)_" "_PSONOW
DO PRINT(T)
+14 SET PSOY=ORIGY
SET PSOYI=PSOTYI
+15 IF PSOX=PSORX
SET PSOX=PSOLX
WRITE @IOF
QUIT
+16 SET PSOX=PSORX
End DoDot:1
IF $ORDER(RX(PSA))
DO HDR
QUIT
+17 QUIT
DTCONNW SET PSDT2=$PIECE(RX(PSA),"^")
SET PSDT2=$EXTRACT(PSDT2,4,5)_"/"_$EXTRACT(PSDT2,6,7)_"/"_($EXTRACT(PSDT2,1,3)+1700)
QUIT
RFILL2 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 SET PSRXX=+^PS(55,DFN,"P",PSRX,0)
+1 IF $DATA(^PSRX(PSRXX,0))
SET PSRFL=$PIECE(^(0),"^",9)
IF $DATA(^(1))&PSRFL
DO RFILL2
IF PSRFL>0
IF $PIECE($GET(^PSRX(PSRXX,"STA")),"^")<10
IF 134'[$EXTRACT(+$PIECE($GET(^("STA")),"^"))
IF $PIECE(^(2),"^",6)>DT
SET RX(PSRXX)=$PIECE(^(2),"^",6)_"^"_PSRFL
+2 QUIT
HDR SET T=PNM
DO PRINT(T)
+1 DO ADD^VADPT
+2 IF $GET(VAPA(1))=""
GOTO HDR5
+3 FOR I=1:1:3
IF $GET(VAPA(I))]""
SET T=VAPA(I)
DO PRINT(T)
+4 SET A=+$GET(VAPA(5))
IF A
SET A=$SELECT($DATA(^DIC(5,A,0)):$PIECE(^(0),"^",2),1:"UNKNOWN")
+5 SET B=$GET(VAPA(4))_", "_A_" "_$SELECT($GET(VAPA(11)):$PIECE(VAPA(11),"^",2),1:$GET(VAPA(6)))
+6 SET T=B
DO PRINT(T)
HDR5 IF $ORDER(RX(0))=""
Begin DoDot:1
+1 SET PSOY=PSOY+PSOYI
SET T="You have no refillable prescriptions as of "_PSONOW_"."
DO PRINT(T)
+2 SET T="Please contact your provider if you need new prescriptions."
DO PRINT(T)
+3 IF '$DATA(PSOINST)
DO SITE
+4 SET PS=$SELECT($DATA(^PS(59,PSOSITE,0)):^(0),1:"")
+5 SET OPSOX=PSOX
SET OPSOY=PSOY
SET T=$PIECE(PS,"^",6)
SET PSOX=2300
SET PSOY=3900
DO PRINT(T)
SET PSOX=OPSOX
SET PSOY=OPSOY
End DoDot:1
SET PSOY=PSOY+PSOYI
QUIT
ADD SET PSOY=PSOY+PSOYI
SET T="Please check prescriptions to be refilled, sign the form, then"
DO PRINT(T)
+1 SET T="mail or return to your pharmacy."
DO PRINT(T)
SET PSOY=PSOY+PSOYI
+2 QUIT
MAIL ;PRINT MAILING ADHESIVE LABEL
+1 SET PS=$SELECT($DATA(^PS(59,PSOSITE,0)):^(0),1:"")
+2 IF $PIECE(PSOSYS,"^",4)
IF $DATA(^PS(59,+$PIECE($GET(PSOSYS),"^",4),0))
SET PS=^PS(59,$PIECE($GET(PSOSYS),"^",4),0)
+3 SET VAADDR1=$PIECE(PS,"^")
SET VASTREET=$PIECE(PS,"^",2)
SET STATE=$SELECT($DATA(^DIC(5,+$PIECE(PS,"^",8),0)):$PIECE(^(0),"^",2),1:"UNKNOWN")
+4 SET PSZIP=$PIECE(PS,"^",5)
SET PSOHZIP=$SELECT(PSZIP["-":PSZIP,1:$EXTRACT(PSZIP,1,5)_$SELECT($EXTRACT(PSZIP,6,9)]"":"-"_$EXTRACT(PSZIP,6,9),1:""))
+5 IF $GET(PSOIO("MLI"))]""
XECUTE PSOIO("MLI")
+6 IF $GET(PSOIO("PSOFONT"))]""
XECUTE PSOIO("PSOFONT")
+7 ; IHS/CIA/PLS - 03/05/04 - Changed from 119 to Pharmacy
+8 ;S TEXT="Attn: (119)" D PRINT(TEXT)
+9 SET TEXT="Attn: Pharmacy"
DO PRINT(TEXT)
+10 SET TEXT=VAADDR1
DO PRINT(TEXT)
+11 SET TEXT=$GET(VASTREET)
DO PRINT(TEXT)
+12 SET TEXT=$PIECE(PS,"^",7)_", "_$GET(STATE)_" "_$GET(PSOHZIP)
DO PRINT(TEXT)
+13 QUIT
PRINT(T) ;
+1 IF $GET(PSOIO(PSOFONT))]""
XECUTE PSOIO(PSOFONT)
+2 IF $GET(PSOIO("ST"))]""
XECUTE PSOIO("ST")
+3 WRITE T,!
+4 IF $GET(PSOIO("ET"))]""
XECUTE PSOIO("ET")
+5 QUIT
QUEUE ; ENTRY POINT TO PRINT STAND-ALONE MULTI-RX FORM
+1 ; DFN SET IF COMING FROM HIDDEN ACTION
SET SAVDFN=$DATA(DFN)
+2 IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
QUIT
+3 IF '$GET(PSOSYS)
SET PSOSYS=$GET(^PS(59.7,1,40.1))
+4 IF '$DATA(PSOINST)
DO SITE
+5 WRITE !
+6 IF $DATA(DFN)
GOTO GETPT2
GETPT SET DIC("A")="Enter patient to reprint Multi-Rx refill form for: "
SET DIC(0)="QEAM"
DO EN^PSOPATLK
SET Y=PSOPTLK
IF Y<0!("^"[X)
KILL PSOPTLK,DIC
QUIT
+1 SET DFN=$PIECE(Y,"^")
GETPT2 DO DEM^VADPT
SET PNM=VADM(1)
+1 IF $PIECE(VADM(6),"^",2)]""
Begin DoDot:1
+2 WRITE $CHAR(7),!!,PNM_" Died "_$PIECE(VADM(6),"^",2)_".",!
End DoDot:1
GOTO GETPT
Q1 WRITE !
KILL POP,ZTSK
SET %ZIS("B")=""
SET %ZIS="MNQ"
SET %ZIS("A")="Select LABEL DEVICE: "
DO ^%ZIS
SET PSLION=ION
KILL %ZIS("A")
+1 IF $GET(POP)
QUIT
+2 IF $GET(IOST(0))
IF '$DATA(^%ZIS(2,IOST(0),55,"B","LL"))
WRITE !,"Must specify a laser labels printer for Multi-Rx form."
GOTO Q1
+3 IF '$GET(IOST(0))
WRITE !,"Nothing queued to print."
HANG 1
QUIT
+4 DO 6^VADPT
DO PID^VADPT6
SET SSNP=""
+5 DO NOW^%DTC
SET Y=$PIECE(%,".")
SET PSOFNOW=%
XECUTE ^DD("DD")
SET PSONOW=Y
+6 FOR G="DFN","PNM","PSOPAR","PSOSITE","SSNP","PSONOW","PSOSYS","PSOINST"
IF $DATA(@G)
SET ZTSAVE(G)=""
+7 SET ZTRTN="DQ^PSOLLL7"
SET ZTIO=PSLION
SET ZTDESC="Outpatient Pharmacy Multi-Rx print"
SET ZTDTH=$HOROLOG
SET PDUZ=DUZ
+8 DO ^%ZISC
DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !!,"Multi-Rx form queued to print",!!
HANG 1
KILL G
+9 IF $GET(SAVDFN)=0
KILL DFN,SAVDFN
+10 QUIT
DQ NEW PSOBIO
SET (I,PSOIO)=0
FOR
SET I=$ORDER(^%ZIS(2,IOST(0),55,I))
IF 'I
QUIT
SET X0=$GET(^(I,0))
IF X0]""
SET PSOIO($PIECE(X0,"^"))=^(1)
SET PSOIO=1
+1 IF $GET(PSOIO("LLI"))]""
XECUTE PSOIO("LLI")
+2 GOTO EN
SITE ;
+1 KILL ^UTILITY("DIQ1",$JOB)
SET DA=$PIECE($$SITE^VASITE(),"^")
+2 IF $GET(DA)>0
SET DIC=4
SET DIQ(0)="I"
SET DR="99"
DO EN^DIQ1
SET PSOINST=$GET(^UTILITY("DIQ1",$JOB,4,DA,99,"I"))
KILL ^UTILITY("DIQ1",$JOB),DA,DR,DIC
+3 IF '$DATA(PSOINST)
SET PSOINST=""
+4 QUIT
