- PSXLBL2 ;BIR/HTW,BAB-CMOP Host Print Labels ;[ 12/18/97 12:48 PM ]
- ;;2.0;CMOP;**1,10**;11 Apr 97
- N I
- L1 W ?3,"VAMC ",SCITY,", ",SSTATE," ",SZIP
- W ?54,"VAMC ",SCITY,", ",SSTATE," ",SZIP
- I $G(REPRINT) W ?102,"(REPRINT)"
- L2 W !,?3,SITE," ",STEL," ",CLKRPH
- W ?54,SITE," ",STEL," ",CLKRPH
- D NOW^%DTC S Y=% X ^DD("DD") S RNOW=$P(Y,":",1,2) K X,Y,%
- W ?102,SITE," ",CLKRPH," ",RNOW
- L3 W !,RX," ",FDT," Fill ",RFTXT
- W ?54,RX," ",FDT," Fill ",RFTXT
- W ?102,RX," ",FDT," Fill ",RFTXT
- L4 W !,PNAME," ",$P(SSN,"-",2,3),?54,PNAME," ",$P(SSN,"-",2,3),?102,PNAME," ",$P(SSN,"-",2,3)
- ; SIG
- S SC=4
- W !
- F I=1:1:SIGN W $G(SIG(I)),?54,$G(SIG(I)),?102,$G(SIG(I)) S SC=SC+1 D
- .I $D(SIG(I+1)),(I#3=0) W @IOF S SC=0 Q
- .I '$D(SIG(I+1)) Q
- .W !
- S SC=7-SC F ZP=1:1:SC W !
- L8 W !,$G(PHYS),?54,$G(PHYS),?102,$G(PHYS)
- W !,"Qty: "_$G(QTY)_" "_$G(VADU)_" "_$G(NURSE)
- W ?54,"Qty: "_$G(QTY)_" "_$G(VADU)_" "_$G(NURSE)
- W ?102,"Qty: "_$G(QTY)_" "_$G(VADU)_" "_$G(NURSE)
- K NURSE,VADU,ZP,SC
- L10 W !,TRUG,?54,TRUG,?102,TRUG
- I REFREM'>0 D TOP^PSXLBLNR G L13
- S X1=EXPDT1,Y=ISD1,X2=DT D ^%DTC I X<30 G L11
- W !,?54,REFREM," Refills remain prior to ",$G(EXPDT),?102,"Mfg ________ Lot# ________" G L12
- L11 W !,?54,"Last fill prior to ",$G(EXPDT),?102,"Mfg ________ Lot# ________"
- L12 W !,SADD1,?54,COPAY," Days Supply: ",$G(TAYS),?102,"Tech__________RPh_________"
- W !,SCITY,", ",SSTATE," ",SZIP
- I $G(PSXBAR) S X="S",X2=BAR S X1=$X W ?54,@IOBARON,X2,@IOBAROFF,*13
- I '$G(PSXBAR) W !!!
- W !,"FORWARDING SERVICE REQUESTED"
- W:($G(REGMAIL)=1) !,?21,"CERTIFIED MAIL"
- W !,?54,$G(PADD1)
- W !,"***CRITICAL MEDICAL SHIPMENT***",?54,$G(PADD2),?102,"Routing: "_$S($G(REGMAIL)=1:"CERTIFIED",1:"REGULAR")_" MAIL"
- W !,?54,$G(PADD3),?102,"Days supply: ",$G(TAYS)," Cap: ",$S($G(CAP):"**NON-SFTY**",1:"SAFETY")
- W !,?54,$G(PADD4),?102,"Isd: ",$G(ISD)," Exp: ",$G(EXPDT)
- W !,PNAME,?54,"*Indicate address change on back of this form",?102,"Last Fill: ",$G(REFLST)
- W !,PADD1,?54,"[ ] Permanent",?102,"Pat. Stat ",PSTAT," Clinic: ",CLINIC
- W !,$G(PADD2),?54,"[ ] Temporary until ",$S($G(PTEMP)]"":PTEMP,1:"__/__/__")
- W ?102,$S($G(WARN)'="":"DRUG WARNING "_$G(WARN),1:"")
- W !,$G(PADD3)
- W !,$G(PADD4),?54,"Signature__________________________________"
- I $G(PSXBAR) S X="S",X2=BAR S X1=$X W ?102,@IOBARON,X2,@IOBAROFF,*13
- L13 W @IOF
- ; PRINT DRUG WARNING
- I $G(WARN)]"" D W @IOF
- .W ?54,PNAME
- .W !,?54,"Rx# ",RX
- .W !,?54,TRUG
- .W !,?54,"DRUG WARNING:"
- .F W=1:1 S W1=$P(WARN,",",W) Q:W1']"" D
- ..Q:'$D(^PS(54,W1,0))
- ..F W2=0:0 S W2=$O(^PS(54,W1,1,W2)) Q:'W2 D
- ...S W3=^PS(54,W1,1,W2,0) W !,?54,W3
- K W,W1,W2,W3,X
- UPDATE ; UPDATE 552.3
- D NOW^%DTC
- I $G(REPRINT)!($G(PSXBLR)) D
- .F UX=0:0 S UX=$O(^PSX(552.3,UX)) Q:'UX!($G(UXOUT)) S UXN=$G(^(UX,0)) D
- ..I $P(UXN,B,2)[BATREF,($P(UXN,B,3)=RX) S $P(^PSX(552.3,UX,0),B,5)=%,UXOUT=1
- I $G(UXOUT) K UXOUT,UXN,UX Q
- ADD L +(^PSX(552.3,0)):DTIME
- S CNT=$P(^PSX(552.3,0),"^",3),CNT=CNT+1
- S CNT4=$P(^PSX(552.3,0),"^",4),CNT4=CNT4+1
- AD1 I $D(^PSX(552.3,CNT)) S CNT=CNT+1,CNT4=CNT4+1 G AD1
- L +^PSX(552.3,CNT):1 I '$T G AD1
- S $P(^PSX(552.3,0),"^",3)=CNT,$P(^PSX(552.3,0),"^",4)=CNT4
- S ^PSX(552.3,CNT,0)="ZMP|"_BATREF_B_RX_B_BAR_B_%_B_DUZ
- S ^PSX(552.3,"AP",BAR,CNT)=""
- L -(^PSX(552.3,0),^PSX(552.3,CNT))
- K CNT,CNT4,%,%I,X,UX,UXOUT,UXN
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXLBL2 3362 printed Feb 18, 2025@23:10:44 Page 2
- PSXLBL2 ;BIR/HTW,BAB-CMOP Host Print Labels ;[ 12/18/97 12:48 PM ]
- +1 ;;2.0;CMOP;**1,10**;11 Apr 97
- +2 NEW I
- L1 WRITE ?3,"VAMC ",SCITY,", ",SSTATE," ",SZIP
- +1 WRITE ?54,"VAMC ",SCITY,", ",SSTATE," ",SZIP
- +2 IF $GET(REPRINT)
- WRITE ?102,"(REPRINT)"
- L2 WRITE !,?3,SITE," ",STEL," ",CLKRPH
- +1 WRITE ?54,SITE," ",STEL," ",CLKRPH
- +2 DO NOW^%DTC
- SET Y=%
- XECUTE ^DD("DD")
- SET RNOW=$PIECE(Y,":",1,2)
- KILL X,Y,%
- +3 WRITE ?102,SITE," ",CLKRPH," ",RNOW
- L3 WRITE !,RX," ",FDT," Fill ",RFTXT
- +1 WRITE ?54,RX," ",FDT," Fill ",RFTXT
- +2 WRITE ?102,RX," ",FDT," Fill ",RFTXT
- L4 WRITE !,PNAME," ",$PIECE(SSN,"-",2,3),?54,PNAME," ",$PIECE(SSN,"-",2,3),?102,PNAME," ",$PIECE(SSN,"-",2,3)
- +1 ; SIG
- +2 SET SC=4
- +3 WRITE !
- +4 FOR I=1:1:SIGN
- WRITE $GET(SIG(I)),?54,$GET(SIG(I)),?102,$GET(SIG(I))
- SET SC=SC+1
- Begin DoDot:1
- +5 IF $DATA(SIG(I+1))
- IF (I#3=0)
- WRITE @IOF
- SET SC=0
- QUIT
- +6 IF '$DATA(SIG(I+1))
- QUIT
- +7 WRITE !
- End DoDot:1
- +8 SET SC=7-SC
- FOR ZP=1:1:SC
- WRITE !
- L8 WRITE !,$GET(PHYS),?54,$GET(PHYS),?102,$GET(PHYS)
- +1 WRITE !,"Qty: "_$GET(QTY)_" "_$GET(VADU)_" "_$GET(NURSE)
- +2 WRITE ?54,"Qty: "_$GET(QTY)_" "_$GET(VADU)_" "_$GET(NURSE)
- +3 WRITE ?102,"Qty: "_$GET(QTY)_" "_$GET(VADU)_" "_$GET(NURSE)
- +4 KILL NURSE,VADU,ZP,SC
- L10 WRITE !,TRUG,?54,TRUG,?102,TRUG
- +1 IF REFREM'>0
- DO TOP^PSXLBLNR
- GOTO L13
- +2 SET X1=EXPDT1
- SET Y=ISD1
- SET X2=DT
- DO ^%DTC
- IF X<30
- GOTO L11
- +3 WRITE !,?54,REFREM," Refills remain prior to ",$GET(EXPDT),?102,"Mfg ________ Lot# ________"
- GOTO L12
- L11 WRITE !,?54,"Last fill prior to ",$GET(EXPDT),?102,"Mfg ________ Lot# ________"
- L12 WRITE !,SADD1,?54,COPAY," Days Supply: ",$GET(TAYS),?102,"Tech__________RPh_________"
- +1 WRITE !,SCITY,", ",SSTATE," ",SZIP
- +2 IF $GET(PSXBAR)
- SET X="S"
- SET X2=BAR
- SET X1=$X
- WRITE ?54,@IOBARON,X2,@IOBAROFF,*13
- +3 IF '$GET(PSXBAR)
- WRITE !!!
- +4 WRITE !,"FORWARDING SERVICE REQUESTED"
- +5 if ($GET(REGMAIL)=1)
- WRITE !,?21,"CERTIFIED MAIL"
- +6 WRITE !,?54,$GET(PADD1)
- +7 WRITE !,"***CRITICAL MEDICAL SHIPMENT***",?54,$GET(PADD2),?102,"Routing: "_$SELECT($GET(REGMAIL)=1:"CERTIFIED",1:"REGULAR")_" MAIL"
- +8 WRITE !,?54,$GET(PADD3),?102,"Days supply: ",$GET(TAYS)," Cap: ",$SELECT($GET(CAP):"**NON-SFTY**",1:"SAFETY")
- +9 WRITE !,?54,$GET(PADD4),?102,"Isd: ",$GET(ISD)," Exp: ",$GET(EXPDT)
- +10 WRITE !,PNAME,?54,"*Indicate address change on back of this form",?102,"Last Fill: ",$GET(REFLST)
- +11 WRITE !,PADD1,?54,"[ ] Permanent",?102,"Pat. Stat ",PSTAT," Clinic: ",CLINIC
- +12 WRITE !,$GET(PADD2),?54,"[ ] Temporary until ",$SELECT($GET(PTEMP)]"":PTEMP,1:"__/__/__")
- +13 WRITE ?102,$SELECT($GET(WARN)'="":"DRUG WARNING "_$GET(WARN),1:"")
- +14 WRITE !,$GET(PADD3)
- +15 WRITE !,$GET(PADD4),?54,"Signature__________________________________"
- +16 IF $GET(PSXBAR)
- SET X="S"
- SET X2=BAR
- SET X1=$X
- WRITE ?102,@IOBARON,X2,@IOBAROFF,*13
- L13 WRITE @IOF
- +1 ; PRINT DRUG WARNING
- +2 IF $GET(WARN)]""
- Begin DoDot:1
- +3 WRITE ?54,PNAME
- +4 WRITE !,?54,"Rx# ",RX
- +5 WRITE !,?54,TRUG
- +6 WRITE !,?54,"DRUG WARNING:"
- +7 FOR W=1:1
- SET W1=$PIECE(WARN,",",W)
- if W1']""
- QUIT
- Begin DoDot:2
- +8 if '$DATA(^PS(54,W1,0))
- QUIT
- +9 FOR W2=0:0
- SET W2=$ORDER(^PS(54,W1,1,W2))
- if 'W2
- QUIT
- Begin DoDot:3
- +10 SET W3=^PS(54,W1,1,W2,0)
- WRITE !,?54,W3
- End DoDot:3
- End DoDot:2
- End DoDot:1
- WRITE @IOF
- +11 KILL W,W1,W2,W3,X
- UPDATE ; UPDATE 552.3
- +1 DO NOW^%DTC
- +2 IF $GET(REPRINT)!($GET(PSXBLR))
- Begin DoDot:1
- +3 FOR UX=0:0
- SET UX=$ORDER(^PSX(552.3,UX))
- if 'UX!($GET(UXOUT))
- QUIT
- SET UXN=$GET(^(UX,0))
- Begin DoDot:2
- +4 IF $PIECE(UXN,B,2)[BATREF
- IF ($PIECE(UXN,B,3)=RX)
- SET $PIECE(^PSX(552.3,UX,0),B,5)=%
- SET UXOUT=1
- End DoDot:2
- End DoDot:1
- +5 IF $GET(UXOUT)
- KILL UXOUT,UXN,UX
- QUIT
- ADD LOCK +(^PSX(552.3,0)):DTIME
- +1 SET CNT=$PIECE(^PSX(552.3,0),"^",3)
- SET CNT=CNT+1
- +2 SET CNT4=$PIECE(^PSX(552.3,0),"^",4)
- SET CNT4=CNT4+1
- AD1 IF $DATA(^PSX(552.3,CNT))
- SET CNT=CNT+1
- SET CNT4=CNT4+1
- GOTO AD1
- +1 LOCK +^PSX(552.3,CNT):1
- IF '$TEST
- GOTO AD1
- +2 SET $PIECE(^PSX(552.3,0),"^",3)=CNT
- SET $PIECE(^PSX(552.3,0),"^",4)=CNT4
- +3 SET ^PSX(552.3,CNT,0)="ZMP|"_BATREF_B_RX_B_BAR_B_%_B_DUZ
- +4 SET ^PSX(552.3,"AP",BAR,CNT)=""
- +5 LOCK -(^PSX(552.3,0),^PSX(552.3,CNT))
- +6 KILL CNT,CNT4,%,%I,X,UX,UXOUT,UXN
- +7 QUIT