PSOLBL2 ;BIR/SAB-LABEL OUTPUT CONT. ;11/18/92 19:15
;;7.0;OUTPATIENT PHARMACY;**16,19,30,71,92,117,135,326**;DEC 1997;Build 11
;External reference to ^PS(51 supported by DBIA 2224
;External reference to ^PS(54 supported by DBIA 2227
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^PS(55 supported by DBIA 2228
;External reference to ^DPT supported by DBIA 3097
;External reference to GMRADPT supported by DBIA 10099
I $P($G(^PSRX(RX,"SIG")),"^",2) K SGY D ^PSOLBL3 G SIGOLD
D SIG
QUIT K SIG,E,F,S Q
SIG K OT S SGY="" F P=1:1:$L(SIG," ") S X=$P(SIG," ",P) D:X]""
.I $D(^PS(51,"A",X)) D
..I $P($G(^PS(55,DFN,"LAN")),"^") S OT=$O(^PS(51,"B",X,0)) I OT,$P($G(^PS(51,OT,4)),"^")]"" S X=$P(^PS(51,OT,4),"^") K OT Q
..S %=^PS(51,"A",X),X=$P(%,"^") I $P(%,"^",2)]"" S Y=$P(SIG," ",P-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(%,"^",2)
.S SGY=SGY_X_" "
S X="",SGC=1 F J=1:1 S Z=$P(SGY," ",J) S:Z="" SGY(SGC)=X Q:Z="" S:$L(X)+$L(Z)'<$S($P(PSOPAR,"^",28):46,1:34) SGY(SGC)=X,SGC=SGC+1,X="" S X=X_Z_" "
SIGOLD I '$P(PSOPAR,"^",28) D K NHC
.K DIC,DR,DIQ,NHC S DIC=2,DA=DFN,DR=148,DIQ="NHC",DIQ(0)="I"
.D EN^DIQ1 K DIC,DR,DIQ
.I NHC(2,DFN,148,"I")="Y"!($P($G(^PS(55,DFN,40)),"^")) S SGC=SGC+1,SGY(SGC)="Expiration:________ Mfg:_________"
;
DPT S X=$S($D(^DPT(DFN,0))#2:^(0),1:""),DOB=$P(X,"^",3),L=$E(X,1)
S Y=$P(X,"^",9),PNM=$P(X,"^") D PID^VADPT S SS="",SSNP=""
I $P(PSOPAR,"^",28) K SIG,E,F,S Q
GMRA X "N X S X=""GMRADPT"" X ^%ZOSF(""TEST"") Q" I '$T S (INT(1),INT(2),INT(3))="" Q
S GMRA="0^1^111" D ^GMRADPT S I1=1,INT(1)="ALLERGIES: ",(INT(2),INT(3))="" F I=0:0 S I=$O(GMRAL(I)) Q:I'>0 S AL=$P(GMRAL(I),U,2) S:$L(INT(I1))+$L(AL)>42 I1=I1+1,INT(I1)="" S INT(I1)=INT(I1)_AL_", "
;K GMRA,GMRAL Q
Q
SIGPH S SIGPH=SIG,X="",SGCPH=1 F J=1:1:100 S Z=$P(SIGPH," ",J) S:Z="" SIGPH(SGCPH)=X S:$L(X)+$L(Z)'<34 SIGPH(SGCPH)=X,SGCPH=SGCPH+1,X="" S X=X_Z_" "
Q
WARN W:'$G(PSOBLALL) @IOF W ?54,PNM,!,?54,"Rx# ",RXN,!,?54,DRUG,!,?54,"DRUG WARNING:" S DIWL=55,DIWR=100,DIWF="W" F WW=1:1 Q:$P(WARN,",",WW,99)="" S PSOWARN=$P(WARN,",",WW) D:$D(^PS(54,PSOWARN,0))
.K ^UTILITY($J,"W") F AA=0:0 S AA=$O(^PS(54,PSOWARN,1,AA)) Q:'AA S X=^(AA,0) D ^DIWP D ^DIWW
K WW,PSOWARN,AA W:$G(PSOBLALL) @IOF Q
REP ;LEFT SIDE ONLY REPRINT FOR NEW LABEL STOCK
K PSOSTLK,ZTKDRUG I $L($T(PSOSTALK^PSOTALK1)) D PSOSTALK^PSOTALK1 S PSOSTLK=1 ; PRINT SCRIPTALK LABEL IF APPLICABLE
S ZTKDRUG="XXXXXX SCRIPTALK RX XXXXXX"
S Y=DATE X ^DD("DD") S DATE=Y S TECH="("_$S($P($G(^PSRX(+$G(RX),"OR1")),"^",5):$P($G(^PSRX(+$G(RX),"OR1")),"^",5),1:$P(RXY,"^",16))_"/"_$S($G(VRPH)&($P(PSOPAR,"^",32)):VRPH,1:" ")_")"
S PSZIP=$P(PS,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
W "VAMC ",$P(PS,"^",7),", ",STATE," ",$G(PSOHZIP),?102,"(REPRINT)" W:$G(RXP) "(PARTIAL)" W !,$P(PS2,"^",2)," ",$P(PS,"^",3),"-",$P(PS,"^",4)," ",TECH
W !,"Rx# ",RXN," ",DATE," Fill ",RXF+1," of ",1+$P(RXY,"^",9),!,PNM
F DR=1:1 Q:$G(SGY(DR))="" D:DR=4!(DR=7)!(DR=10)!(DR=13) W !,$G(SGY(DR))
.F GG=1:1:27 W !
I DR>4 S KK=$S(DR=5!(DR=8)!(DR=11):2,(DR=6)!(DR=9)!(DR=12):1,1:0) I KK F HH=1:1:KK W !
I DR=2 W !!
I DR=3 W !
W ! S PSDU=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),660)),"^",8) W $G(PHYS),!,"Qty: "_$G(QTY)," ",$G(PSDU),$S($G(PSDU)="":" ",1:" "),$S($G(NURSE):"Mfg______Exp______",1:"")
I $G(PSOSTLK) W !,$S($G(PSOTALK)&('$G(PSOTREP)):ZTKDRUG,1:DRUG)
I '$G(PSOSTLK) W !,DRUG
K PSDU W !!,$P(PS,"^",2),!,$P(PS,"^",7),", ",STATE," ",$G(PSOHZIP),!!!!,"FORWARDING SERVICE REQUESTED",!
I "C"[$E(MW) W ?21,"CERTIFIED MAIL",!
E W !
W !,$S($G(PS55)=2:"***DO NOT MAIL***",1:"***CRITICAL MEDICAL SHIPMENT***")
W !!!,PNM,!,$S($D(PSMP(1)):PSMP(1),1:VAPA(1)),!,$S($D(PSMP(2)):PSMP(2),$D(PSMP(1)):"",1:$G(ADDR(2))),!,$S($D(PSMP(3)):PSMP(3),$D(PSMP(1)):"",1:$G(ADDR(3))),!,$S($D(PSMP(4)):PSMP(4),$D(PSMP(1)):"",1:$G(ADDR(4)))
W @IOF Q
MUL ;
I $G(PSOBARS),$P($G(PSOPAR),"^",19) W:J=1 !!! W:J=2 !
E W:J=1 !!!!!!!!! W:J=2 !!!!!!!! W:J=3 !!!!!! W:J=4 !!!! W:J=5 !!
W !,"Use the label above to mail the computer",!,"copies back to us. Apply enough postage",!,"to your envelope to ensure delivery."
Q
MULT W !,"Use the label above to mail the computer",?54,"(",PSLN,")",!,"copies back to us. Apply enough postage",?60,"PATIENT'S SIGNATURE "_$E(DT,4,5),"/",$E(DT,6,7),"/",($E(DT,1,3)+1700),!,"to your envelope to ensure delivery."
Q
PRINT S (PSONOPR,PSOWSTOP,PSOASTOP)=0 F CCC=1:1 Q:$G(PSONOPR) D
.W ?54,$G(^TMP($J,"PSOWPT",CCC)) S:'$O(^(CCC)) PSOWSTOP=1
.W ?102,$G(^TMP($J,"PSOAPT",CCC)),! S:'$O(^(CCC)) PSOASTOP=1
.I PSOWSTOP,PSOASTOP S PSONOPR=1
K ^TMP($J,"PSOWARN"),^TMP($J,"ALWA"),^TMP($J,"PSOWPT"),^TMP($J,"PSOAPT"),PSONKA,PSONULL,WWW,GMRA,GMRAL,PSOWARN,JJJ,WCNT,RRR,ALG,ALCNT,EEE,FFF,PSOLG,PSOLGA,PSORY,CCC,PSONOPR,PSOWSTOP,PSOASTOP W @IOF
Q
KILL K PSCLN,DATE,DR,RXY,RFLMSG,COPIES,DRUG,LMI,LINE,INT,ISD,I1,MW,STATE,SIDE,SGY,PATST,PRTFL,PHYS,SGC,VRPH,NLWS,Y,TECH,LFLDT,EXPDT,COPAYVAR,NURSE,X,X1,X2,PSCAP,LOT,DIFF,DAYS,ZZ,GG,HH,KK,ULN,PSZIP,PSOHZIP,PSOPROV,PSMP,REPRINT,PS55,PS55X
K PSOLBLDR,PSOLBLPS,OSIG,OSGY
Q
TRAIL I $P(^PS(59,PSOSITE,1),"^",28) D ^PSOLBLN2
D:'$P(^PS(59,PSOSITE,1),"^",28) ^PSOLBLS I $D(^TMP($J,"PSOCP",DFN)),'$P(^PS(59,PSOSITE,1),"^",28) D INV^PSOCPE
K RXPI,PSORX,RXP,PSOIOS,PSOLAPPL,XXX,TECH,COPAYVAR,PHYS,MFG,NURSE,STATE,SIDE,COPIES,EXDT,ISD,PSOINST,RXN,RXY,VADT,DEA,WARN,FDT,QTY,PARST,PDA,PS,PS1,PS2,PSL,PSNP,INRX,RR,XTYPE,SSNP,PNM,ADDR,PSODBQ,PSOLASTF
K ^TMP($J,"PSOCP",+$G(PSOCPN)),PSDFNFLG,PSOLAPPL
I '$G(PSOBLALL) K PSOCPN,PSOLBLCP
Q
PSOLBL2 ;BIR/SAB-LABEL OUTPUT CONT. ;11/18/92 19:15
+1 ;;7.0;OUTPATIENT PHARMACY;**16,19,30,71,92,117,135,326**;DEC 1997;Build 11
+2 ;External reference to ^PS(51 supported by DBIA 2224
+3 ;External reference to ^PS(54 supported by DBIA 2227
+4 ;External reference to ^PSDRUG supported by DBIA 221
+5 ;External reference to ^PS(55 supported by DBIA 2228
+6 ;External reference to ^DPT supported by DBIA 3097
+7 ;External reference to GMRADPT supported by DBIA 10099
+8 IF $PIECE($GET(^PSRX(RX,"SIG")),"^",2)
KILL SGY
DO ^PSOLBL3
GOTO SIGOLD
+9 DO SIG
QUIT KILL SIG,E,F,S
QUIT
SIG KILL OT
SET SGY=""
FOR P=1:1:$LENGTH(SIG," ")
SET X=$PIECE(SIG," ",P)
IF X]""
Begin DoDot:1
+1 IF $DATA(^PS(51,"A",X))
Begin DoDot:2
+2 IF $PIECE($GET(^PS(55,DFN,"LAN")),"^")
SET OT=$ORDER(^PS(51,"B",X,0))
IF OT
IF $PIECE($GET(^PS(51,OT,4)),"^")]""
SET X=$PIECE(^PS(51,OT,4),"^")
KILL OT
QUIT
+3 SET %=^PS(51,"A",X)
SET X=$PIECE(%,"^")
IF $PIECE(%,"^",2)]""
SET Y=$PIECE(SIG," ",P-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
IF Y>1
SET X=$PIECE(%,"^",2)
End DoDot:2
+4 SET SGY=SGY_X_" "
End DoDot:1
+5 SET X=""
SET SGC=1
FOR J=1:1
SET Z=$PIECE(SGY," ",J)
IF Z=""
SET SGY(SGC)=X
IF Z=""
QUIT
IF $LENGTH(X)+$LENGTH(Z)'<$SELECT($PIECE(PSOPAR,"^",28)
SET SGY(SGC)=X
SET SGC=SGC+1
SET X=""
SET X=X_Z_" "
SIGOLD IF '$PIECE(PSOPAR,"^",28)
Begin DoDot:1
+1 KILL DIC,DR,DIQ,NHC
SET DIC=2
SET DA=DFN
SET DR=148
SET DIQ="NHC"
SET DIQ(0)="I"
+2 DO EN^DIQ1
KILL DIC,DR,DIQ
+3 IF NHC(2,DFN,148,"I")="Y"!($PIECE($GET(^PS(55,DFN,40)),"^"))
SET SGC=SGC+1
SET SGY(SGC)="Expiration:________ Mfg:_________"
End DoDot:1
KILL NHC
+4 ;
DPT SET X=$SELECT($DATA(^DPT(DFN,0))#2:^(0),1:"")
SET DOB=$PIECE(X,"^",3)
SET L=$EXTRACT(X,1)
+1 SET Y=$PIECE(X,"^",9)
SET PNM=$PIECE(X,"^")
DO PID^VADPT
SET SS=""
SET SSNP=""
+2 IF $PIECE(PSOPAR,"^",28)
KILL SIG,E,F,S
QUIT
GMRA XECUTE "N X S X=""GMRADPT"" X ^%ZOSF(""TEST"") Q"
IF '$TEST
SET (INT(1),INT(2),INT(3))=""
QUIT
+1 SET GMRA="0^1^111"
DO ^GMRADPT
SET I1=1
SET INT(1)="ALLERGIES: "
SET (INT(2),INT(3))=""
FOR I=0:0
SET I=$ORDER(GMRAL(I))
IF I'>0
QUIT
SET AL=$PIECE(GMRAL(I),U,2)
IF $LENGTH(INT(I1))+$LENGTH(AL)>42
SET I1=I1+1
SET INT(I1)=""
SET INT(I1)=INT(I1)_AL_", "
+2 ;K GMRA,GMRAL Q
+3 QUIT
SIGPH SET SIGPH=SIG
SET X=""
SET SGCPH=1
FOR J=1:1:100
SET Z=$PIECE(SIGPH," ",J)
IF Z=""
SET SIGPH(SGCPH)=X
IF $LENGTH(X)+$LENGTH(Z)'<34
SET SIGPH(SGCPH)=X
SET SGCPH=SGCPH+1
SET X=""
SET X=X_Z_" "
+1 QUIT
WARN IF '$GET(PSOBLALL)
WRITE @IOF
WRITE ?54,PNM,!,?54,"Rx# ",RXN,!,?54,DRUG,!,?54,"DRUG WARNING:"
SET DIWL=55
SET DIWR=100
SET DIWF="W"
FOR WW=1:1
IF $PIECE(WARN,",",WW,99)=""
QUIT
SET PSOWARN=$PIECE(WARN,",",WW)
IF $DATA(^PS(54,PSOWARN,0))
Begin DoDot:1
+1 KILL ^UTILITY($JOB,"W")
FOR AA=0:0
SET AA=$ORDER(^PS(54,PSOWARN,1,AA))
IF 'AA
QUIT
SET X=^(AA,0)
DO ^DIWP
DO ^DIWW
End DoDot:1
+2 KILL WW,PSOWARN,AA
IF $GET(PSOBLALL)
WRITE @IOF
QUIT
REP ;LEFT SIDE ONLY REPRINT FOR NEW LABEL STOCK
+1 ; PRINT SCRIPTALK LABEL IF APPLICABLE
KILL PSOSTLK,ZTKDRUG
IF $LENGTH($TEXT(PSOSTALK^PSOTALK1))
DO PSOSTALK^PSOTALK1
SET PSOSTLK=1
+2 SET ZTKDRUG="XXXXXX SCRIPTALK RX XXXXXX"
+3 SET Y=DATE
XECUTE ^DD("DD")
SET DATE=Y
SET TECH="("_$SELECT($PIECE($GET(^PSRX(+$GET(RX),"OR1")),"^",5):$PIECE($GET(^PSRX(+$GET(RX),"OR1")),"^",5),1:$PIECE(RXY,"^",16))_"/"_$SELECT($GET(VRPH)&($PIECE(PSOPAR,"^",32)):VRPH,1:" ")_")"
+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 WRITE "VAMC ",$PIECE(PS,"^",7),", ",STATE," ",$GET(PSOHZIP),?102,"(REPRINT)"
IF $GET(RXP)
WRITE "(PARTIAL)"
WRITE !,$PIECE(PS2,"^",2)," ",$PIECE(PS,"^",3),"-",$PIECE(PS,"^",4)," ",TECH
+6 WRITE !,"Rx# ",RXN," ",DATE," Fill ",RXF+1," of ",1+$PIECE(RXY,"^",9),!,PNM
+7 FOR DR=1:1
IF $GET(SGY(DR))=""
QUIT
IF DR=4!(DR=7)!(DR=10)!(DR=13)
Begin DoDot:1
+8 FOR GG=1:1:27
WRITE !
End DoDot:1
WRITE !,$GET(SGY(DR))
+9 IF DR>4
SET KK=$SELECT(DR=5!(DR=8)!(DR=11):2,(DR=6)!(DR=9)!(DR=12):1,1:0)
IF KK
FOR HH=1:1:KK
WRITE !
+10 IF DR=2
WRITE !!
+11 IF DR=3
WRITE !
+12 WRITE !
SET PSDU=$PIECE($GET(^PSDRUG($PIECE($GET(^PSRX(RX,0)),"^",6),660)),"^",8)
WRITE $GET(PHYS),!,"Qty: "_$GET(QTY)," ",$GET(PSDU),$SELECT($GET(PSDU)="":" ",1:" "),$SELECT($GET(NURSE):"Mfg______Exp______",1:"")
+13 IF $GET(PSOSTLK)
WRITE !,$SELECT($GET(PSOTALK)&('$GET(PSOTREP)):ZTKDRUG,1:DRUG)
+14 IF '$GET(PSOSTLK)
WRITE !,DRUG
+15 KILL PSDU
WRITE !!,$PIECE(PS,"^",2),!,$PIECE(PS,"^",7),", ",STATE," ",$GET(PSOHZIP),!!!!,"FORWARDING SERVICE REQUESTED",!
+16 IF "C"[$EXTRACT(MW)
WRITE ?21,"CERTIFIED MAIL",!
+17 IF '$TEST
WRITE !
+18 WRITE !,$SELECT($GET(PS55)=2:"***DO NOT MAIL***",1:"***CRITICAL MEDICAL SHIPMENT***")
+19 WRITE !!!,PNM,!,$SELECT($DATA(PSMP(1)):PSMP(1),1:VAPA(1)),!,$SELECT($DATA(PSMP(2)):PSMP(2),$DATA(PSMP(1)):"",1:$GET(ADDR(2))),!,$SELECT($DATA(PSMP(3)):PSMP(3),$DATA(PSMP(1)):"",1:$GET(ADDR(3))),!,$SELECT(...
... $DATA(PSMP(4)):PSMP(4),$DATA(PSMP(1)):"",1:$GET(ADDR(4)))
+20 WRITE @IOF
QUIT
MUL ;
+1 IF $GET(PSOBARS)
IF $PIECE($GET(PSOPAR),"^",19)
IF J=1
WRITE !!!
IF J=2
WRITE !
+2 IF '$TEST
IF J=1
WRITE !!!!!!!!!
IF J=2
WRITE !!!!!!!!
IF J=3
WRITE !!!!!!
IF J=4
WRITE !!!!
IF J=5
WRITE !!
+3 WRITE !,"Use the label above to mail the computer",!,"copies back to us. Apply enough postage",!,"to your envelope to ensure delivery."
+4 QUIT
MULT WRITE !,"Use the label above to mail the computer",?54,"(",PSLN,")",!,"copies back to us. Apply enough postage",?60,"PATIENT'S SIGNATURE "_$EXTRACT(DT,4,5),"/",$EXTRACT(DT,6,7),"/",($EXTRACT(DT,1,3)+1700),!,"to your envelope to ensure deliver
y."
+1 QUIT
PRINT SET (PSONOPR,PSOWSTOP,PSOASTOP)=0
FOR CCC=1:1
IF $GET(PSONOPR)
QUIT
Begin DoDot:1
+1 WRITE ?54,$GET(^TMP($JOB,"PSOWPT",CCC))
IF '$ORDER(^(CCC))
SET PSOWSTOP=1
+2 WRITE ?102,$GET(^TMP($JOB,"PSOAPT",CCC)),!
IF '$ORDER(^(CCC))
SET PSOASTOP=1
+3 IF PSOWSTOP
IF PSOASTOP
SET PSONOPR=1
End DoDot:1
+4 KILL ^TMP($JOB,"PSOWARN"),^TMP($JOB,"ALWA"),^TMP($JOB,"PSOWPT"),^TMP($JOB,"PSOAPT"),PSONKA,PSONULL,WWW,GMRA,GMRAL,PSOWARN,JJJ,WCNT,RRR,ALG,ALCNT,EEE,FFF,PSOLG,PSOLGA,PSORY,CCC,PSONOPR,PSOWSTOP,PSOASTOP
WRITE @IOF
+5 QUIT
KILL KILL PSCLN,DATE,DR,RXY,RFLMSG,COPIES,DRUG,LMI,LINE,INT,ISD,I1,MW,STATE,SIDE,SGY,PATST,PRTFL,PHYS,SGC,VRPH,NLWS,Y,TECH,LFLDT,EXPDT,COPAYVAR,NURSE,X,X1,X2,PSCAP,LOT,DIFF,DAYS,ZZ,GG,HH,KK,ULN,PSZIP,PSOHZIP,PSOPROV,PSMP,REPRINT,PS55,PS55X
+1 KILL PSOLBLDR,PSOLBLPS,OSIG,OSGY
+2 QUIT
TRAIL IF $PIECE(^PS(59,PSOSITE,1),"^",28)
DO ^PSOLBLN2
+1 IF '$PIECE(^PS(59,PSOSITE,1),"^",28)
DO ^PSOLBLS
IF $DATA(^TMP($JOB,"PSOCP",DFN))
IF '$PIECE(^PS(59,PSOSITE,1),"^",28)
DO INV^PSOCPE
+2 KILL RXPI,PSORX,RXP,PSOIOS,PSOLAPPL,XXX,TECH,COPAYVAR,PHYS,MFG,NURSE,STATE,SIDE,COPIES,EXDT,ISD,PSOINST,RXN,RXY,VADT,DEA,WARN,FDT,QTY,PARST,PDA,PS,PS1,PS2,PSL,PSNP,INRX,RR,XTYPE,SSNP,PNM,ADDR,PSODBQ,PSOLASTF
+3 KILL ^TMP($JOB,"PSOCP",+$GET(PSOCPN)),PSDFNFLG,PSOLAPPL
+4 IF '$GET(PSOBLALL)
KILL PSOCPN,PSOLBLCP
+5 QUIT
