PSOLLLH.m

PSOLLLH ;BIR/EJW - HIPAA/NCPDP LASER LABELS ;29-May-2012 14:53;PLS

 ;;7.0;OUTPATIENT PHARMACY;**161,148,244,200,326,321,1015**;DEC 1997;Build 62

 ;

 ;Reference to DUR1^BPSNCPD3 supported by DBIA 4560

 ;

 ;*244 ignore Rx status > 11

 ;

 ; Modified - IHS/MSC/PLS - 05/26/2010 - Line PLANNM+1

SIGLOG N PSOSEQ,J,RXF,RXY,RXN,RX,FIRST,DATE,BLNKLIN,RX2,FDT,BLNKLN2,LAST,CNT

 D DEM^VADPT

 S FIRST=1,LAST=0

 I '$G(REPRINT) D NOWINDOW I NOWIN Q

 K NOWIN

 S $P(BLNKLN2," ",32)=" "

 S $P(BLNKLIN,"_",32)="_"

 F PSOSEQ=1:1:$L(PPL,",") S RX=$P(PPL,",",PSOSEQ) D

 .I RX="" Q

 .Q:$G(^PSRX(RX,"STA"))>11                           ;*244

 .S RXY=$G(^PSRX(RX,0)) I RXY="" Q

 .I $P(RXY,"^",2)'=$G(DFN) Q  ;*321

 .S CNT=$G(CNT)+1

 .S RX2=$G(^PSRX(RX,2)),FDT=$P(RX2,"^",2)

 .I FIRST!(CNT#4=1) D HDR,BARC S FIRST=0

 .S RXF=+$O(^PSRX(RX,1,"A"),-1)

 .I RXF>0 I +^PSRX(RX,1,RXF,0)'<FDT S FDT=+^(0)

 .S DATE=$E(FDT,1,7),Y=DATE X ^DD("DD") S DATE=Y

 .S RXN=$P(RXY,"^")

 .S T=RXN_" ("_(RXF)_") "

 .N PSODRNM

 .S PSODRNM=$$ZZ^PSOSUTL(RX)

 .S T=T_$E(FDT,4,5)_"/"_$E(FDT,6,7)_"/"_$E(FDT,2,3)_" "_$E(PSODRNM,1,(27-$L(RXN))) D PRINT(T)

 S LAST=1 D SIGN

 I $D(ZTQUEUED) S ZTREQ="@"

 Q

 ;

SIGN ;

 I '$G(CNT) Q

 N II

 S II=CNT#4

 I LAST,II>0 F J=1:1:(4-II) S T=" " D PRINT(T)

 S PSOY=PSOY+10

 S T="Pt. Sig."_BLNKLIN D PRINT(T)

 S PSOY=PSOY+5

 D PRINT($$PLANNM())

 S PSOY=PSOY+15

 S T="Relation_____ Counseling Refused__ Accepted__" D PRINT(T)

 S PSOY=PSOY+10

 S T=PNM_"  "_$G(SSNP) D PRINT(T,1)

 Q

 ;

HDR ;

 I 'FIRST D SIGN W @IOF

 I $G(PSOIO("BLH"))]"" X PSOIO("BLH")

 S T="VAMC "_$P(PS,"^",7)_", "_STATE_" "_$G(PSOHZIP) D PRINT(T)

 S T=$P(PS2,"^",2)_"  Ph: "_$P(PS,"^",3)_"-"_$P(PS,"^",4)_"       "_$G(PSONOW) D PRINT(T)

 I $G(PSOIO("BLB"))]"" X PSOIO("BLB")

 S XFONT=$E(PSOFONT,2,99)

 N REPMSG

 S REPMSG=BLNKLN2_"(REPRINT)"

 S T="By signing below"_$S($G(REPRINT):REPMSG,1:"") D PRINT(T,1)

 S T="you acknowledge receipt of the following Rx's" D PRINT(T,1)

 S T=" " D PRINT(T)

 S PSOY=PSOY-20

 Q

 ;

PRINT(T,B) ;

 S BOLD=$G(B)

 I 'BOLD,$G(PSOIO(PSOFONT))]"" X PSOIO(PSOFONT)

 I BOLD,$G(PSOIO(PSOFONT_"B"))]"" X PSOIO(PSOFONT_"B")

 I $G(PSOIO("ST"))]"" X PSOIO("ST")

 W T,!

 I $G(PSOIO("ET"))]"" X PSOIO("ET")

 I BOLD,$G(PSOIO(PSOFONT))]"" X PSOIO(PSOFONT) ;TURN OFF BOLDING

 Q

 ;

QUEUE ; ENTRY POINT TO REPRINT SIGNATURE LOG

 I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) Q

 N REPRINT,PS,STATE,PS2,PSOHZIP

 S PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:"")

 S PS2=$P(PS,"^")_"^"_$P(PS,"^",6)

 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:""))

 S REPRINT=1

LRP W !! S DIC("S")="I $P($G(^(0)),""^"",2),$D(^(""STA"")),$P($G(^(""STA"")),""^"")<10",DIC="^PSRX(",DIC("A")="Reprint Signature Log for Prescription: ",DIC(0)="QEAZ" D ^DIC K P,DIC("A") I Y<0!("^"[X) D KILL Q

 W !

 S (PPL,RX)=+Y

 N RXY

 S RXY=$G(^PSRX(RX,0)) I RXY="" Q

 S DFN=$P(RXY,"^",2)

GETPT2 D DEM^VADPT S PNM=VADM(1)

 I $P(VADM(6),"^",2)]"" D  G LRP

 .W $C(7),!!,PNM_" Died "_$P(VADM(6),"^",2)_".",!

 D 6^VADPT,PID^VADPT6 S SSNP=""

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 Signature Log Reprint" G Q1

 I '$G(IOST(0)) W !,"Nothing queued to print." H 1 Q

 D NOW^%DTC S Y=$P(%,"."),PSOFNOW=% X ^DD("DD") S PSONOW=Y

 F G="PPL","REPRINT","PNM","STATE","PS2","PSOHZIP","PSOPAR","PSOSITE","PS","PSONOW","PSOSYS","SSNP" S:$D(@G) ZTSAVE(G)=""

 S ZTRTN="DQ^PSOLLLH",ZTIO=PSLION,ZTDESC="Outpatient Pharmacy Signature Log Reprint",ZTDTH=$H,PDUZ=DUZ

 D ^%ZISC,^%ZTLOAD W:$D(ZTSK) !!,"Signature Log Reprint queued",!! H 1 K G

 G QUEUE

 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 SIGLOG

 ;

PLANNM() ; Returns Insurance Name (3rd Party)

 Q ""  ;IHS/MSC/PLS - 05/26/10

 S PLANNM=""

 N I,DUR,RX

 F I=1:1:$L(PPL,",") S RX=+$P(PPL,",",I) D  I PLANNM'="" Q

 .I 'RX Q

 .D DUR1^BPSNCPD3(RX,$$LSTRFL^PSOBPSU1(RX),.DUR) S PLANNM=$G(DUR(1,"INSURANCE NAME"))

 Q PLANNM

BARC I '$G(FIRST) G BARCE ; PRINT BARCODE FOR 1 RX ON 1ST SIGLOG LABEL ONLY

 I $G(PSOIO("BLBC"))]"" X PSOIO("BLBC") I $G(NOBARC) G BARCE

 I '$D(PSOINST) D INST

 S X2=PSOINST_"-"_RX W X2

 I $G(PSOIO("EBLBC"))]"" X PSOIO("EBLBC")

BARCE Q

 ;

KILL ; CLEAN UP VARIABLES

 K DIC,DFN,PNM,PPL,PSZIP,RX,SSNP,VA,VADDR1,VADM,VAEL,VAPA,VASTREET

 Q

INST ;

 K ^UTILITY("DIQ1",$J) S DA=$P($$SITE^VASITE(),"^")

 I $G(DA) 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

 Q

 ;

NOWINDOW ; ON ORIGINAL PRINT - DON'T PRINT IF ALL ARE MAIL

 N I,RX,RXF,MW,RXP,RXY

 S NOWIN=1

 F I=1:1:$L(PPL,",") S RX=$P(PPL,",",I) D  I 'NOWIN Q

 .I RX="" Q

 .I $G(^PSRX(RX,"STA"))>11 Q

 .S RXY=$G(^PSRX(RX,0)) I RXY="" Q

 .I '$D(^PSRX(RX,1)) S MW=$P(RXY,"^",11) I MW="W" S NOWIN=0 Q

 .S RXF=$O(^PSRX(RX,1,99),-1) I RXF>0 S MW=$P($G(^PSRX(RX,1,RXF,0)),"^",2) I MW="W" S NOWIN=0

 .S RXP=$O(^PSRX(RX,"P",99),-1) I RXP>0 S MW=$P($G(^PSRX(RX,"P",RXP,0)),"^",2) I MW="W" S NOWIN=0

 Q

PSOLLLH   ;BIR/EJW - HIPAA/NCPDP LASER LABELS ;29-May-2012 14:53;PLS

 +1       ;;7.0;OUTPATIENT PHARMACY;**161,148,244,200,326,321,1015**;DEC 1997;Build 62

 +2       ;

 +3       ;Reference to DUR1^BPSNCPD3 supported by DBIA 4560

 +4       ;

 +5       ;*244 ignore Rx status > 11

 +6       ;

 +7       ; Modified - IHS/MSC/PLS - 05/26/2010 - Line PLANNM+1

SIGLOG     NEW PSOSEQ,J,RXF,RXY,RXN,RX,FIRST,DATE,BLNKLIN,RX2,FDT,BLNKLN2,LAST,CNT

 +1        DO DEM^VADPT

 +2        SET FIRST=1

           SET LAST=0

 +3        IF '$GET(REPRINT)

               DO NOWINDOW

               IF NOWIN

                   QUIT 

 +4        KILL NOWIN

 +5        SET $PIECE(BLNKLN2," ",32)=" "

 +6        SET $PIECE(BLNKLIN,"_",32)="_"

 +7        FOR PSOSEQ=1:1:$LENGTH(PPL,",")

               SET RX=$PIECE(PPL,",",PSOSEQ)

               Begin DoDot:1

 +8                IF RX=""

                       QUIT 

 +9       ;*244

                   IF $GET(^PSRX(RX,"STA"))>11

                       QUIT 

 +10               SET RXY=$GET(^PSRX(RX,0))

                   IF RXY=""

                       QUIT 

 +11      ;*321

                   IF $PIECE(RXY,"^",2)'=$GET(DFN)

                       QUIT 

 +12               SET CNT=$GET(CNT)+1

 +13               SET RX2=$GET(^PSRX(RX,2))

                   SET FDT=$PIECE(RX2,"^",2)

 +14               IF FIRST!(CNT#4=1)

                       DO HDR

                       DO BARC

                       SET FIRST=0

 +15               SET RXF=+$ORDER(^PSRX(RX,1,"A"),-1)

 +16               IF RXF>0

                       IF +^PSRX(RX,1,RXF,0)'<FDT

                           SET FDT=+^(0)

 +17               SET DATE=$EXTRACT(FDT,1,7)

                   SET Y=DATE

                   XECUTE ^DD("DD")

                   SET DATE=Y

 +18               SET RXN=$PIECE(RXY,"^")

 +19               SET T=RXN_" ("_(RXF)_") "

 +20               NEW PSODRNM

 +21               SET PSODRNM=$$ZZ^PSOSUTL(RX)

 +22               SET T=T_$EXTRACT(FDT,4,5)_"/"_$EXTRACT(FDT,6,7)_"/"_$EXTRACT(FDT,2,3)_" "_$EXTRACT(PSODRNM,1,(27-$LENGTH(RXN)))

                   DO PRINT(T)

               End DoDot:1

 +23       SET LAST=1

           DO SIGN

 +24       IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +25       QUIT 

 +26      ;

SIGN      ;

 +1        IF '$GET(CNT)

               QUIT 

 +2        NEW II

 +3        SET II=CNT#4

 +4        IF LAST

               IF II>0

                   FOR J=1:1:(4-II)

                       SET T=" "

                       DO PRINT(T)

 +5        SET PSOY=PSOY+10

 +6        SET T="Pt. Sig."_BLNKLIN

           DO PRINT(T)

 +7        SET PSOY=PSOY+5

 +8        DO PRINT($$PLANNM())

 +9        SET PSOY=PSOY+15

 +10       SET T="Relation_____ Counseling Refused__ Accepted__"

           DO PRINT(T)

 +11       SET PSOY=PSOY+10

 +12       SET T=PNM_"  "_$GET(SSNP)

           DO PRINT(T,1)

 +13       QUIT 

 +14      ;

HDR       ;

 +1        IF 'FIRST

               DO SIGN

               WRITE @IOF

 +2        IF $GET(PSOIO("BLH"))]""

               XECUTE PSOIO("BLH")

 +3        SET T="VAMC "_$PIECE(PS,"^",7)_", "_STATE_" "_$GET(PSOHZIP)

           DO PRINT(T)

 +4        SET T=$PIECE(PS2,"^",2)_"  Ph: "_$PIECE(PS,"^",3)_"-"_$PIECE(PS,"^",4)_"       "_$GET(PSONOW)

           DO PRINT(T)

 +5        IF $GET(PSOIO("BLB"))]""

               XECUTE PSOIO("BLB")

 +6        SET XFONT=$EXTRACT(PSOFONT,2,99)

 +7        NEW REPMSG

 +8        SET REPMSG=BLNKLN2_"(REPRINT)"

 +9        SET T="By signing below"_$SELECT($GET(REPRINT):REPMSG,1:"")

           DO PRINT(T,1)

 +10       SET T="you acknowledge receipt of the following Rx's"

           DO PRINT(T,1)

 +11       SET T=" "

           DO PRINT(T)

 +12       SET PSOY=PSOY-20

 +13       QUIT 

 +14      ;

PRINT(T,B) ;

 +1        SET BOLD=$GET(B)

 +2        IF 'BOLD

               IF $GET(PSOIO(PSOFONT))]""

                   XECUTE PSOIO(PSOFONT)

 +3        IF BOLD

               IF $GET(PSOIO(PSOFONT_"B"))]""

                   XECUTE PSOIO(PSOFONT_"B")

 +4        IF $GET(PSOIO("ST"))]""

               XECUTE PSOIO("ST")

 +5        WRITE T,!

 +6        IF $GET(PSOIO("ET"))]""

               XECUTE PSOIO("ET")

 +7       ;TURN OFF BOLDING

           IF BOLD

               IF $GET(PSOIO(PSOFONT))]""

                   XECUTE PSOIO(PSOFONT)

 +8        QUIT 

 +9       ;

QUEUE     ; ENTRY POINT TO REPRINT SIGNATURE LOG

 +1        IF '$DATA(PSOPAR)

               DO ^PSOLSET

               IF '$DATA(PSOPAR)

                   QUIT 

 +2        NEW REPRINT,PS,STATE,PS2,PSOHZIP

 +3        SET PS=$SELECT($DATA(^PS(59,PSOSITE,0)):^(0),1:"")

 +4        SET PS2=$PIECE(PS,"^")_"^"_$PIECE(PS,"^",6)

 +5        IF $PIECE(PSOSYS,"^",4)

               IF $DATA(^PS(59,+$PIECE($GET(PSOSYS),"^",4),0))

                   SET PS=^PS(59,$PIECE($GET(PSOSYS),"^",4),0)

 +6        SET VAADDR1=$PIECE(PS,"^")

           SET VASTREET=$PIECE(PS,"^",2)

           SET STATE=$SELECT($DATA(^DIC(5,+$PIECE(PS,"^",8),0)):$PIECE(^(0),"^",2),1:"UNKNOWN")

 +7        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:""))

 +8        SET REPRINT=1

LRP        WRITE !!

           SET DIC("S")="I $P($G(^(0)),""^"",2),$D(^(""STA"")),$P($G(^(""STA"")),""^"")<10"

           SET DIC="^PSRX("

           SET DIC("A")="Reprint Signature Log for Prescription: "

           SET DIC(0)="QEAZ"

           DO ^DIC

           KILL P,DIC("A")

           IF Y<0!("^"[X)

               DO KILL

               QUIT 

 +1        WRITE !

 +2        SET (PPL,RX)=+Y

 +3        NEW RXY

 +4        SET RXY=$GET(^PSRX(RX,0))

           IF RXY=""

               QUIT 

 +5        SET DFN=$PIECE(RXY,"^",2)

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 LRP

 +3        DO 6^VADPT

           DO PID^VADPT6

           SET SSNP=""

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 Signature Log Reprint"

                   GOTO Q1

 +3        IF '$GET(IOST(0))

               WRITE !,"Nothing queued to print."

               HANG 1

               QUIT 

 +4        DO NOW^%DTC

           SET Y=$PIECE(%,".")

           SET PSOFNOW=%

           XECUTE ^DD("DD")

           SET PSONOW=Y

 +5        FOR G="PPL","REPRINT","PNM","STATE","PS2","PSOHZIP","PSOPAR","PSOSITE","PS","PSONOW","PSOSYS","SSNP"

               IF $DATA(@G)

                   SET ZTSAVE(G)=""

 +6        SET ZTRTN="DQ^PSOLLLH"

           SET ZTIO=PSLION

           SET ZTDESC="Outpatient Pharmacy Signature Log Reprint"

           SET ZTDTH=$HOROLOG

           SET PDUZ=DUZ

 +7        DO ^%ZISC

           DO ^%ZTLOAD

           IF $DATA(ZTSK)

               WRITE !!,"Signature Log Reprint queued",!!

           HANG 1

           KILL G

 +8        GOTO QUEUE

 +9        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 SIGLOG

 +3       ;

PLANNM()  ; Returns Insurance Name (3rd Party)

 +1       ;IHS/MSC/PLS - 05/26/10

           QUIT ""

 +2        SET PLANNM=""

 +3        NEW I,DUR,RX

 +4        FOR I=1:1:$LENGTH(PPL,",")

               SET RX=+$PIECE(PPL,",",I)

               Begin DoDot:1

 +5                IF 'RX

                       QUIT 

 +6                DO DUR1^BPSNCPD3(RX,$$LSTRFL^PSOBPSU1(RX),.DUR)

                   SET PLANNM=$GET(DUR(1,"INSURANCE NAME"))

               End DoDot:1

               IF PLANNM'=""

                   QUIT 

 +7        QUIT PLANNM

BARC      ; PRINT BARCODE FOR 1 RX ON 1ST SIGLOG LABEL ONLY

           IF '$GET(FIRST)

               GOTO BARCE

 +1        IF $GET(PSOIO("BLBC"))]""

               XECUTE PSOIO("BLBC")

               IF $GET(NOBARC)

                   GOTO BARCE

 +2        IF '$DATA(PSOINST)

               DO INST

 +3        SET X2=PSOINST_"-"_RX

           WRITE X2

 +4        IF $GET(PSOIO("EBLBC"))]""

               XECUTE PSOIO("EBLBC")

BARCE      QUIT 

 +1       ;

KILL      ; CLEAN UP VARIABLES

 +1        KILL DIC,DFN,PNM,PPL,PSZIP,RX,SSNP,VA,VADDR1,VADM,VAEL,VAPA,VASTREET

 +2        QUIT 

INST      ;

 +1        KILL ^UTILITY("DIQ1",$JOB)

           SET DA=$PIECE($$SITE^VASITE(),"^")

 +2        IF $GET(DA)

               SET DIC=4

               SET DIQ(0)="I"

               SET DR="99"

               DO EN^DIQ1

               SET PSOINST=$GET(^UTILITY("DIQ1",$JOB,4,DA,99,"I"))

 +3        KILL ^UTILITY("DIQ1",$JOB),DA,DR,DIC

 +4        QUIT 

 +5       ;

NOWINDOW  ; ON ORIGINAL PRINT - DON'T PRINT IF ALL ARE MAIL

 +1        NEW I,RX,RXF,MW,RXP,RXY

 +2        SET NOWIN=1

 +3        FOR I=1:1:$LENGTH(PPL,",")

               SET RX=$PIECE(PPL,",",I)

               Begin DoDot:1

 +4                IF RX=""

                       QUIT 

 +5                IF $GET(^PSRX(RX,"STA"))>11

                       QUIT 

 +6                SET RXY=$GET(^PSRX(RX,0))

                   IF RXY=""

                       QUIT 

 +7                IF '$DATA(^PSRX(RX,1))

                       SET MW=$PIECE(RXY,"^",11)

                       IF MW="W"

                           SET NOWIN=0

                           QUIT 

 +8                SET RXF=$ORDER(^PSRX(RX,1,99),-1)

                   IF RXF>0

                       SET MW=$PIECE($GET(^PSRX(RX,1,RXF,0)),"^",2)

                       IF MW="W"

                           SET NOWIN=0

 +9                SET RXP=$ORDER(^PSRX(RX,"P",99),-1)

                   IF RXP>0

                       SET MW=$PIECE($GET(^PSRX(RX,"P",RXP,0)),"^",2)

                       IF MW="W"

                           SET NOWIN=0

               End DoDot:1

               IF 'NOWIN

                   QUIT 

 +10       QUIT