- 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 Feb 18, 2025@23:10:43 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