PSXLBL1 ;BIR/HTW,BAB-CMOP Host Label Print..Set Up Variables ; [ 07/21/98 7:27 AM ]
;;2.0;CMOP;**13,18**;11 Apr 97
S ^PSX(553,1,"P")="R"
S:$D(ZTQUEUED) ZTREQ="@"
A S B="|",S="\S\",F="\F\",R="\R\",A="" S X=158 X ^%ZOSF("RM")
NTE S ^PSX(552.1,"APR",BATREF)=""
F G=0:0 S G=$O(^PSX(552.1,N514,"S",G)) Q:'G D
.S NTE=^PSX(552.1,N514,"S",G,0),NZ=$P(NTE,B,2)
.I NZ=1 S SITE=+$P(NTE,B,4),SNAME=$P($P(NTE,B,4),S,2)
.I S SADD=$P(NTE,F,2),L=1,STEL=$P(NTE,F,3)
.I F M="SADD1","SADD2","SCITY","SSTATE","SZIP" S @M=$P(SADD,S,L),L=L+1
.I NZ=2 S Q=$S($G(Q):Q+1,1:1),N=$P(NTE,B,4) D STRIP S N2(Q)=N Q
.I NZ=3 S V=$S($G(V):V+1,1:1),N=$P(NTE,B,4) D STRIP S N3(V)=N Q
.I NZ=4 S C=$S($G(C):C+1,1:1),N=$P(NTE,B,4) D STRIP S N4(C)=N Q
S SADD3=SCITY_" "_SSTATE_" "_SZIP I $G(SADD2)="" S SADD2=SADD3,SADD3=""
;Combine REFILL/NON-REFILL/COPAY NARRATIVES
S CT=1
F P=0:0 S P=$O(N2(P)) Q:'P S NARR(CT)=N2(P),CT=CT+1
S NARR(CT)="" S CT=CT+1
F P=0:0 S P=$O(N3(P)) Q:'P S NARR(CT)=N3(P),CT=CT+1
S NARR(CT)="COPAY" S CT=CT+1
F P=0:0 S P=$O(N4(P)) Q:'P S NARR(CT)=N4(P),CT=CT+1
K Q,V,C,L,N,NTE,NZ,CT,N2,N3,N4
G:$G(PSXBLR) PRINT^PSXLBLU
S A1=PSXBEG-1
F S A1=$O(^PSX(552.2,PSXREF,BATREF,A1)) Q:'A1!(A1>PSXEND) S ZA2=A1-1 D MAIN
END G F514^PSXLBLU
Q
MAIN F S ZA2=$O(^PSX(552.2,ZA2)) Q:'ZA2!(ZA2>A1) D RX,^PSXLBLT S DA=ZA2,DR="1////5",DIE="^PSX(552.2," D ^DIE K DIE,DA,DR
Q
RX F C=1:0 S C=$O(^PSX(552.2,ZA2,"T",C)) Q:'C S J=^(C,0) D
.I $P(^PSX(552.2,ZA2,0),"^")'[BATREF Q
.S J1=$P(J,B),J2=$P(J,B,2)
.I J1="PID" D Q
..S (SSN,SSN1)=$E($P(J,B,4),1,9),S1=$E(SSN,1,3),S2=$E(SSN,4,5),S3=$E(SSN,6,9)
..S SSN=S1_"-"_S2_"-"_S3
..S PNAME=$TR($P(J,B,6),"^",",")
..S PA=$P(J,B,12),L=1
..F M="PADD1","PADD2","PCITY","PSTATE","PZIP" S @M=$P(PA,U,L),L=L+1
..K S1,S2,S3,L,PA,M
.I J2=5 S C5=$S($G(C5):C5+1,1:1) D STRIPF S MRX(C5)=$P(P2,B,4) K P2 Q
.I J2=6 S C6=$S($G(C6):C6+1,1:1) D STRIPF S SRX(C6)=$P(P2,B,4) K P2 Q
.I J1="RX1" D Q
..S CRX=$S($G(CRX):CRX+1,1:1),RX(CRX)=$P(J,B,13)
..F X=15,20,21,22,25,26,27,31 S RX(CRX)=RX(CRX)_U_$P(J,B,X)
..K X Q
.I J1="ZX1" K CNTE D Q
..S ZX(CRX)=$P(J,B,2) F X=3:1:19 S ZX(CRX)=ZX(CRX)_U_$P(J,B,X)
..K X
.I J2=7 S CNTE=$S($G(CNTE):CNTE+1,1:2) S RX(CRX,CNTE)=$P(J,B,4) Q
.I J2=8 S TEMP=$P(J,B,4) D
..S PTEMP=$S($P(TEMP,F)=1:$P(TEMP,F,2),1:"")
..S PADD3=$P($G(TEMP),F,3)
..I $G(PTEMP) S PTEMP=$E(PTEMP,5,6)_"/"_$E(PTEMP,7,8)_"/"_$E(PTEMP,1,4)
..K TEMP
PADD I $G(PADD2)="" S PADD2=PCITY_", "_PSTATE_" "_PZIP G CLN1
I $G(PADD3)="" S PADD3=PCITY_", "_PSTATE_" "_PZIP G CLN1
S PADD4=PCITY_", "_PSTATE_" "_PZIP G CLN1
CLN1 ;
K C5,C6,CRX,P,P1,P2,J,J1,J2,G,SADD,M,L,Q,V,C,N,S1,S2,S3,PA,X
K CNTE,NTE,CT
SET F C=0:0 S C=$O(RX(C)) Q:'C D I '$G(RESET)!($G(RESET)<C)!($G(RESET)="TOP") D ^PSXLBL2
.S C2=1 F C1="QTY","ID","TRUG","SPARE","REFCT","ISD","REFREM","EXPDT","REFLST","RX","SIG" S @C1=$P(RX(C),U,C2),C2=C2+1
.S Z50=$O(^PSDRUG("AQ1",ID,"")) I $G(Z50) D
..S Z1=$P($G(^PSDRUG(Z50,"ND")),"^"),Z2=$P($G(^("ND")),"^",3) I $G(Z2) D
...;S VADU=$P($G(^PSNDF(Z1,5,Z2,2)),"^",4)
...S ZZX=$$PROD2^PSNAPIS(Z1,Z2),VADU=$P(ZZX,"^",4) K ZZX
.S ISD1=ISD
.F ZZT="ISD","EXPDT" S @ZZT=@ZZT-17000000 S:@ZZT'>0 @ZZT="" I +(@ZZT)>0 S:ZZT="EXPDT" EXPDT1=EXPDT S Y=@ZZT X ^DD("DD") S @ZZT=Y K Y
.I $G(REFLST)>0 S REFLST=$E(REFLST,5,6)_"/"_$E(REFLST,7,8)_"/"_$E(REFLST,1,4)
.S RX(C,1)=SIG K SIG S C2=1 F C1="RX1","SITE","MAILID","Z","RXCT","RFTXT" S @C1=$P(ZX(C),U,C2),C2=C2+1
.F C1="PHYS","REGMAIL","CLKRPH","FDT","COPAY","RENW" S @C1=$P(ZX(C),U,C2),C2=C2+1
.F C1="CAP","TAYS","Z","BAR","WARN","PSTAT","CLINIC" S @C1=$P(ZX(C),U,C2),C2=C2+1
.S FDT=FDT-17000000 S:FDT'>0 FDT="" I FDT>0 S Y=FDT X ^DD("DD") S FDT=Y
.S CLERK=$P($P(CLKRPH,"/"),"(",2),VERPHARM=$P($P(CLKRPH,"/",2),")") I $G(WARN)]"" S WARN=$TR(WARN,"~",",")
.S RFTXT=$P($P(RFTXT,"(",2),")"),R=$P(RFTXT,"of"),V=$P(RFTXT,"of",2),RFTXT=R_" of "_V
.S COPAY=$S($G(COPAY)<1:"NO COPAY",1:"COPAY") I COPAY="COPAY" S COPAY(C)=RX_U_TRUG_U_TAYS,COPAYES=1
.F N=0:0 S N=$O(RX(C,N)) Q:'N S SIGN=N
.I $G(RX(C,SIGN))["Exp:" S NURSE=$G(RX(C,SIGN)) K RX(C,SIGN),SIGN,N
.S Y=DT X ^DD("DD") S TODAY=Y K ^UTILITY($J,"W") S DIWL=1,DIWR=48,DIWF="C48" F N=0:0 S N=$O(RX(C,N)) Q:'N S X=RX(C,N) D ^DIWP
.F N=0:0 S N=$O(^UTILITY($J,"W",1,N)) Q:'N S SIG(N)=^(N,0),SIGN=N
.K ^UTILITY($J),N,SPARE,Z,Y,R,V,N,N1,Z50,Z1,Z2
Q
STRIPF S P=$L(J,"\F\"),P2="" F I=1:1:P S P1=$P(J,"\F\",I),P2=P2_U_P1
K P,P1,I Q
STRIP Q:N'["\R\" S P=$L(N,"\R\"),P2="" F I=1:1:P S P1=$P(N,"\R\",I),P2=P2_" "_P1
S N=P2 K P,P1,P2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXLBL1 4573 printed Sep 23, 2025@19:20:20 Page 2
PSXLBL1 ;BIR/HTW,BAB-CMOP Host Label Print..Set Up Variables ; [ 07/21/98 7:27 AM ]
+1 ;;2.0;CMOP;**13,18**;11 Apr 97
+2 SET ^PSX(553,1,"P")="R"
+3 if $DATA(ZTQUEUED)
SET ZTREQ="@"
A SET B="|"
SET S="\S\"
SET F="\F\"
SET R="\R\"
SET A=""
SET X=158
XECUTE ^%ZOSF("RM")
NTE SET ^PSX(552.1,"APR",BATREF)=""
+1 FOR G=0:0
SET G=$ORDER(^PSX(552.1,N514,"S",G))
if 'G
QUIT
Begin DoDot:1
+2 SET NTE=^PSX(552.1,N514,"S",G,0)
SET NZ=$PIECE(NTE,B,2)
+3 IF NZ=1
SET SITE=+$PIECE(NTE,B,4)
SET SNAME=$PIECE($PIECE(NTE,B,4),S,2)
+4 IF $TEST
SET SADD=$PIECE(NTE,F,2)
SET L=1
SET STEL=$PIECE(NTE,F,3)
+5 IF $TEST
FOR M="SADD1","SADD2","SCITY","SSTATE","SZIP"
SET @M=$PIECE(SADD,S,L)
SET L=L+1
+6 IF NZ=2
SET Q=$SELECT($GET(Q):Q+1,1:1)
SET N=$PIECE(NTE,B,4)
DO STRIP
SET N2(Q)=N
QUIT
+7 IF NZ=3
SET V=$SELECT($GET(V):V+1,1:1)
SET N=$PIECE(NTE,B,4)
DO STRIP
SET N3(V)=N
QUIT
+8 IF NZ=4
SET C=$SELECT($GET(C):C+1,1:1)
SET N=$PIECE(NTE,B,4)
DO STRIP
SET N4(C)=N
QUIT
End DoDot:1
+9 SET SADD3=SCITY_" "_SSTATE_" "_SZIP
IF $GET(SADD2)=""
SET SADD2=SADD3
SET SADD3=""
+10 ;Combine REFILL/NON-REFILL/COPAY NARRATIVES
+11 SET CT=1
+12 FOR P=0:0
SET P=$ORDER(N2(P))
if 'P
QUIT
SET NARR(CT)=N2(P)
SET CT=CT+1
+13 SET NARR(CT)=""
SET CT=CT+1
+14 FOR P=0:0
SET P=$ORDER(N3(P))
if 'P
QUIT
SET NARR(CT)=N3(P)
SET CT=CT+1
+15 SET NARR(CT)="COPAY"
SET CT=CT+1
+16 FOR P=0:0
SET P=$ORDER(N4(P))
if 'P
QUIT
SET NARR(CT)=N4(P)
SET CT=CT+1
+17 KILL Q,V,C,L,N,NTE,NZ,CT,N2,N3,N4
+18 if $GET(PSXBLR)
GOTO PRINT^PSXLBLU
+19 SET A1=PSXBEG-1
+20 FOR
SET A1=$ORDER(^PSX(552.2,PSXREF,BATREF,A1))
if 'A1!(A1>PSXEND)
QUIT
SET ZA2=A1-1
DO MAIN
END GOTO F514^PSXLBLU
+1 QUIT
MAIN FOR
SET ZA2=$ORDER(^PSX(552.2,ZA2))
if 'ZA2!(ZA2>A1)
QUIT
DO RX
DO ^PSXLBLT
SET DA=ZA2
SET DR="1////5"
SET DIE="^PSX(552.2,"
DO ^DIE
KILL DIE,DA,DR
+1 QUIT
RX FOR C=1:0
SET C=$ORDER(^PSX(552.2,ZA2,"T",C))
if 'C
QUIT
SET J=^(C,0)
Begin DoDot:1
+1 IF $PIECE(^PSX(552.2,ZA2,0),"^")'[BATREF
QUIT
+2 SET J1=$PIECE(J,B)
SET J2=$PIECE(J,B,2)
+3 IF J1="PID"
Begin DoDot:2
+4 SET (SSN,SSN1)=$EXTRACT($PIECE(J,B,4),1,9)
SET S1=$EXTRACT(SSN,1,3)
SET S2=$EXTRACT(SSN,4,5)
SET S3=$EXTRACT(SSN,6,9)
+5 SET SSN=S1_"-"_S2_"-"_S3
+6 SET PNAME=$TRANSLATE($PIECE(J,B,6),"^",",")
+7 SET PA=$PIECE(J,B,12)
SET L=1
+8 FOR M="PADD1","PADD2","PCITY","PSTATE","PZIP"
SET @M=$PIECE(PA,U,L)
SET L=L+1
+9 KILL S1,S2,S3,L,PA,M
End DoDot:2
QUIT
+10 IF J2=5
SET C5=$SELECT($GET(C5):C5+1,1:1)
DO STRIPF
SET MRX(C5)=$PIECE(P2,B,4)
KILL P2
QUIT
+11 IF J2=6
SET C6=$SELECT($GET(C6):C6+1,1:1)
DO STRIPF
SET SRX(C6)=$PIECE(P2,B,4)
KILL P2
QUIT
+12 IF J1="RX1"
Begin DoDot:2
+13 SET CRX=$SELECT($GET(CRX):CRX+1,1:1)
SET RX(CRX)=$PIECE(J,B,13)
+14 FOR X=15,20,21,22,25,26,27,31
SET RX(CRX)=RX(CRX)_U_$PIECE(J,B,X)
+15 KILL X
QUIT
End DoDot:2
QUIT
+16 IF J1="ZX1"
KILL CNTE
Begin DoDot:2
+17 SET ZX(CRX)=$PIECE(J,B,2)
FOR X=3:1:19
SET ZX(CRX)=ZX(CRX)_U_$PIECE(J,B,X)
+18 KILL X
End DoDot:2
QUIT
+19 IF J2=7
SET CNTE=$SELECT($GET(CNTE):CNTE+1,1:2)
SET RX(CRX,CNTE)=$PIECE(J,B,4)
QUIT
+20 IF J2=8
SET TEMP=$PIECE(J,B,4)
Begin DoDot:2
+21 SET PTEMP=$SELECT($PIECE(TEMP,F)=1:$PIECE(TEMP,F,2),1:"")
+22 SET PADD3=$PIECE($GET(TEMP),F,3)
+23 IF $GET(PTEMP)
SET PTEMP=$EXTRACT(PTEMP,5,6)_"/"_$EXTRACT(PTEMP,7,8)_"/"_$EXTRACT(PTEMP,1,4)
+24 KILL TEMP
End DoDot:2
End DoDot:1
PADD IF $GET(PADD2)=""
SET PADD2=PCITY_", "_PSTATE_" "_PZIP
GOTO CLN1
+1 IF $GET(PADD3)=""
SET PADD3=PCITY_", "_PSTATE_" "_PZIP
GOTO CLN1
+2 SET PADD4=PCITY_", "_PSTATE_" "_PZIP
GOTO CLN1
CLN1 ;
+1 KILL C5,C6,CRX,P,P1,P2,J,J1,J2,G,SADD,M,L,Q,V,C,N,S1,S2,S3,PA,X
+2 KILL CNTE,NTE,CT
SET FOR C=0:0
SET C=$ORDER(RX(C))
if 'C
QUIT
Begin DoDot:1
+1 SET C2=1
FOR C1="QTY","ID","TRUG","SPARE","REFCT","ISD","REFREM","EXPDT","REFLST","RX","SIG"
SET @C1=$PIECE(RX(C),U,C2)
SET C2=C2+1
+2 SET Z50=$ORDER(^PSDRUG("AQ1",ID,""))
IF $GET(Z50)
Begin DoDot:2
+3 SET Z1=$PIECE($GET(^PSDRUG(Z50,"ND")),"^")
SET Z2=$PIECE($GET(^("ND")),"^",3)
IF $GET(Z2)
Begin DoDot:3
+4 ;S VADU=$P($G(^PSNDF(Z1,5,Z2,2)),"^",4)
+5 SET ZZX=$$PROD2^PSNAPIS(Z1,Z2)
SET VADU=$PIECE(ZZX,"^",4)
KILL ZZX
End DoDot:3
End DoDot:2
+6 SET ISD1=ISD
+7 FOR ZZT="ISD","EXPDT"
SET @ZZT=@ZZT-17000000
if @ZZT'>0
SET @ZZT=""
IF +(@ZZT)>0
if ZZT="EXPDT"
SET EXPDT1=EXPDT
SET Y=@ZZT
XECUTE ^DD("DD")
SET @ZZT=Y
KILL Y
+8 IF $GET(REFLST)>0
SET REFLST=$EXTRACT(REFLST,5,6)_"/"_$EXTRACT(REFLST,7,8)_"/"_$EXTRACT(REFLST,1,4)
+9 SET RX(C,1)=SIG
KILL SIG
SET C2=1
FOR C1="RX1","SITE","MAILID","Z","RXCT","RFTXT"
SET @C1=$PIECE(ZX(C),U,C2)
SET C2=C2+1
+10 FOR C1="PHYS","REGMAIL","CLKRPH","FDT","COPAY","RENW"
SET @C1=$PIECE(ZX(C),U,C2)
SET C2=C2+1
+11 FOR C1="CAP","TAYS","Z","BAR","WARN","PSTAT","CLINIC"
SET @C1=$PIECE(ZX(C),U,C2)
SET C2=C2+1
+12 SET FDT=FDT-17000000
if FDT'>0
SET FDT=""
IF FDT>0
SET Y=FDT
XECUTE ^DD("DD")
SET FDT=Y
+13 SET CLERK=$PIECE($PIECE(CLKRPH,"/"),"(",2)
SET VERPHARM=$PIECE($PIECE(CLKRPH,"/",2),")")
IF $GET(WARN)]""
SET WARN=$TRANSLATE(WARN,"~",",")
+14 SET RFTXT=$PIECE($PIECE(RFTXT,"(",2),")")
SET R=$PIECE(RFTXT,"of")
SET V=$PIECE(RFTXT,"of",2)
SET RFTXT=R_" of "_V
+15 SET COPAY=$SELECT($GET(COPAY)<1:"NO COPAY",1:"COPAY")
IF COPAY="COPAY"
SET COPAY(C)=RX_U_TRUG_U_TAYS
SET COPAYES=1
+16 FOR N=0:0
SET N=$ORDER(RX(C,N))
if 'N
QUIT
SET SIGN=N
+17 IF $GET(RX(C,SIGN))["Exp:"
SET NURSE=$GET(RX(C,SIGN))
KILL RX(C,SIGN),SIGN,N
+18 SET Y=DT
XECUTE ^DD("DD")
SET TODAY=Y
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=48
SET DIWF="C48"
FOR N=0:0
SET N=$ORDER(RX(C,N))
if 'N
QUIT
SET X=RX(C,N)
DO ^DIWP
+19 FOR N=0:0
SET N=$ORDER(^UTILITY($JOB,"W",1,N))
if 'N
QUIT
SET SIG(N)=^(N,0)
SET SIGN=N
+20 KILL ^UTILITY($JOB),N,SPARE,Z,Y,R,V,N,N1,Z50,Z1,Z2
End DoDot:1
IF '$GET(RESET)!($GET(RESET)<C)!($GET(RESET)="TOP")
DO ^PSXLBL2
+21 QUIT
STRIPF SET P=$LENGTH(J,"\F\")
SET P2=""
FOR I=1:1:P
SET P1=$PIECE(J,"\F\",I)
SET P2=P2_U_P1
+1 KILL P,P1,I
QUIT
STRIP if N'["\R\"
QUIT
SET P=$LENGTH(N,"\R\")
SET P2=""
FOR I=1:1:P
SET P1=$PIECE(N,"\R\",I)
SET P2=P2_" "_P1
+1 SET N=P2
KILL P,P1,P2
+2 QUIT
