source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLLLH.m@ 1274

PSOLLLH ;BIR/EJW - HIPAA/NCPDP LASER LABELS ;7/20/06 10:21am
 ;;7.0;OUTPATIENT PHARMACY;**161,148,244,200**;DEC 1997;Build 7
 ;
 ;Reference to DUR1^BPSNCPD3 supported by DBIA 4560
 ;
 ;*244 ignore Rx status > 11
 ;
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
 .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=$G(VA("BID"))
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)
 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