source: FOIAVistA/trunk/r/CMOP-PSX/PSXLBL1.m@ 1535

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