APSPSLBL ;IHS/DSD/JCM/ENM - IHS SUMMARY LABEL;17-Jan-2006 09:36;SM
;;7.0;IHS PHARMACY MODIFICATIONS;**1003,1004**;09/03/97
;
;THIS ROUTINE DOES THE PRINTING OF THE REFILL OR PARTIAL
;SUMMARY LABEL TO BE PLACED IN THE PATIENTS CHART IF THIS SITE
;PARAMETER HAS BEEN CHOSEN. PLEASE BE SURE THAT THE ESCAPE SEQUENCES
;FOR YOUR PRINTER HAVE BEEN ENTERED IN YOUR TERMINAL TYPE FILE FOR
;CONDENSED PRINT AND A SOFT RESET OR 10,12 PITCH.
;
; Modified - IHS/CIA/PLS - 01/21/04, 03/08/04, 07/27/04, 08/08/2005
EP ;IHS/DSD/ENM 11/09/94 ENTRY POINT FOR SUM OPT
N APSPZZN,ARRAY,APSPFLG,PSODFN,PSZW,PSZL,PSZB,PSZE,PSZK,PSZTAB
N APSPQFLG,APSPEDT,PSODFN,AUPDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX
N PSOLIST,PSOSD,PSOOPT,APSPID,PSONUM,PSOSD,PSZB,PSZDRUG,PSZE
;N APSPID,APSHRN,Y
N APSPID,APSHRN,Y,APSPZDT ;IHS/CIA/PLS - 08/08/2005
D:'$D(PSOPAR) ^PSOLSET
S APSPQFLG=0,APSPEDT=0
D PARM
D PAT^APSPNUM
Q:'$D(PSODFN)
EPP ;
D PROFILE^PSORX1
S APSPID=1 ;USED IN PSOLIST
S PSOOPT=-1,PSONUM="LIST" D EN^APSPNUM
I $G(Y(1))']"" D EMSG,EOJ Q
G:Y["^" EP
DEV ;
S %ZIS="QM"
S %ZIS("A")="Enter SUMMARY Device: ",IOP=$G(PSOLAP) D ^%ZIS
G:POP EOJ
I $D(IO("Q")),IO=IO(0) D G DEV
.W !!,"Sorry, you cannot queue to your screen or to a slave printer.",!
.K IO("Q") D ^%ZISC
I $D(IO("Q")) D
.S ZTRTN="EP1^APSPSLBL",ZTIO=ION
.F G="PSOSITE","PSOPAR","%APSITE","PRF","PSZW","PSZK","PSZE","PSZL","PSZTAB","PSZB","PSONUM","PSOLIST(1)" S:$D(@G) ZTSAVE(G)=""
.S ZTDESC="Outpatient Pharm Summary Label"
.D ^%ZTLOAD
E D
.D EP1
EXIT Q
EP1 ;INITIALIZE
Q:'$G(PSOLIST(1))
N APSP,APSPN,APSPD,APSPS,APSPQ,APSPF,APSPZ,N
F APSPZ=1:1 S APSPRX=$P(PSOLIST(1),",",APSPZ) Q:APSPRX="" S N=APSPZ D ESET
D EP2,EOJ
Q
ESET ;
S APSP=^PSRX(APSPRX,0),APSPN=$P(APSP,U,2),APSPD=$P(APSP,U,6),APSPS=$P(^PSRX(APSPRX,"SIG"),"^",1),APSPQ=$P(APSP,U,7),APSPF=$P(^PSRX(APSPRX,2),U,2)
;
; dmh added this next SIG change because orders put in sometimes
; set the sig in SIG1 wp field.....6/20/2002
I APSPS="" S APSPS=$G(^PSRX(APSPRX,"SIG1",1,0)) ;dmh 6/20/2002
;
S APSXPS=$S($D(^PS(59,PSOSITE,0)):^(0),1:""),APSNBR=$P(APSXPS,"^",6) ;IHS/DSD/ENM 02/05/97 GET SITE NUMBER FROM SITE FILE
S PNM=$P(^DPT(APSPN,0),U),PSZDRUG=$P(^PSDRUG(APSPD,0),U),APSHRN=$S($G(^AUPNPAT(APSPN,41,APSNBR,0)):$P(^(0),U,2),1:"") ;IHS/DSD/ENM 02/05/97
S ARRAY(N)=$E(PNM,1,PSZW-8)_"^"_APSPRX_"^"_PSZDRUG_"^"_APSPS_"^"_APSPQ_"^"_APSPF_"^"_APSHRN
Q
;
EP2 ;EP
N AAPSITE,PSZCW,PSZCTAB,PZX,PSZW,PSZL,PSZB,PSZE,PSZK,PSZTAB
N FDT,NUM,PSOZSLBL,PSZCTAB,QTY,SIG,PSZZL,E,L,LENGTH
N APSP,APSPD,PSZE
D PARM
I $G(APSPZZN)]"" S N=APSPZZN
S PZX=N,NUM=1,C=0,FDT=$P(ARRAY(N),"^",6)
S AAPSITE=^APSPCTRL(PSOSITE,0)
S PSOZSLBL("COPIES")=$S($P(AAPSITE,"^",36)]"":$P(AAPSITE,"^",36),1:1)
;
S PSZZL=PSZL-1 ; THIS SETS THE NUMBER OF LINES TO PRINT
;AFTER THE PATIENTS NAME AND DATE IS PRINTED
S PSZCW=$P(^APSPCTRL(PSOSITE,0),"^",14) ;IHS/DSD/ENM 08/01/96
S PSZCTAB=$P(^APSPCTRL(PSOSITE,0),"^",13) ;IHS/DSD/ENM 08/01/96
S:PSZCW<PSZW PSZCW=PSZW*1.6\1
;THE ABOVE LINES SETS MY COMPRESSED LABEL WIDTH AND
;MY COMPRESSED LEFT MARGIN IF NOT ALREADY SET IN
;THE IHS SITE PARAMETERS
;
S IOP=$G(PSOLAP) D ^%ZIS U IO
;
I $E(IOST,1,2)="P-",$D(^%ZIS(2,IOST(0),12.1))#2,^(12.1)]"",$D(^%ZIS(2,IOST(0),6))#2,$P(^(6),U,1)]"" W @($P(^%ZIS(2,IOST(0),12.1),U,1))
;THE ABOVE LINE CHECKS TO SEE IF WE ARE USING A TERMINAL OR
;PRINTER AND IF ESCAPE CODES ARE SET UP IN TERMINAL TYPE FILE
;IHS/DSD/ENM/POC 05/11/98 NEXT THREE LINES
;
F PSOZSLBL("I")=1:1:PSOZSLBL("COPIES") D
.S PZX=N,NUM=1 D BEGIN S C=0 ;IHS/DSD/ENM/POC 05/11/98 ADDED PZX AND NUM
D FEED
I $G(PSOFROM)]"" D EOJ ;IHS/DSD/ENM 07/31/96
Q
BEGIN ;
F I=1:1:PSZB W ! ;THIS SETS MY LINE FEEDS AT BEGINNING OF LABEL
;
;PATIENTS NAME & DATE OF ISSUE
W !,?(PSZCTAB),$P(ARRAY(N),"^",1)_" : "_APSHRN_" "
I $G(APSPID)]"" W ?(PSZCTAB+PSZCW-9),+$E(APSPEDT,4,5),"-",$E(APSPEDT,6,7),"-",$E(APSPEDT,2,3) G ZZL ; Display Last Fill Date
W ?(PSZCTAB+PSZCW-9),+$E(FDT,4,5),"-",$E(FDT,6,7),"-",$E(FDT,2,3)
;
ZZL ;LABEL INFORMATION
F N=NUM:1:PZX D LABEL S C=C+1 Q:C=PSZZL
;
F I=1:1:PSZE+(PSZZL-C) W ! ; Set at Top of Form
I $D(ARRAY(N+1)) S C=0,NUM=N+1 G BEGIN
Q
;
FEED I $D(PSZK),PSZK S L=PSZL+PSZE+PSZB*PSZK F I=1:1:L W !
;THE ABOVE LINE ACTS AS A FORM FEED WHERE PSZK
;EQUALS THE NUMBER OF FORM FEEDS
Q
;
EOJ ;
I $E(IOST,1,2)="P-",$D(^%ZIS(2,IOST(0),6))#2,$P(^(6),U,1)]"" W @($P(^%ZIS(2,IOST(0),6),U,1))
D ^%ZISC
U IO
Q
LABEL ;
S LENGTH=$L($P(ARRAY(N),"^",3,5))+1
;
S DRUG=$E($P(ARRAY(N),"^",3),1,PSZCW-5) ;Truncates Drug Name if needed.
;
S E=PSZCW-$L(DRUG)-2 ;POSITION WHERE SIG SHOULD PRINT
;
S QTY=$P(ARRAY(N),"^",5) ;THE QUANTITY ISSUED
;
S SIG=$E($P(ARRAY(N),"^",4),1,PSZCW-$L(QTY)-2+E)
;THE ABOVE LINE SETS THE VALUE AND MAX LENGTH OF SIG
;
I LENGTH'>PSZCW W !,?(PSZCTAB),DRUG," ",SIG,?(PSZCTAB+PSZCW-$L(QTY)),QTY Q
;THE ABOVE LINE PRINTS DRUG,SIG,QTY ON ONE LINE IF IT WILL FIT
;
I C=(PSZZL-1) S N=N-1 W ! Q ;MAKES SURE THERE ARE TWO
;LINES AVAILABLE TO PRINT ON AND RESETS N TO CORRECT VALUE
; AND DOES A LINE FEED IF NOT
;
W !,?(PSZCTAB),DRUG," ",$E(SIG,1,E) ;FIRST LINE
;
I $E(SIG,E+1)'=" " I $E(SIG,E+1)'="" W "-"
;
W !,?(PSZCTAB),$E(SIG,E+1,99)
W ?(PSZCTAB+PSZCW-$L(QTY)),QTY
;THE ABOVE TWO LINES PRINT THE SECOND LINE
;
S C=C+1
;
Q
EMSG ;IHS/DSD/ENM 01/29/97
W !,"No Rx's found for this date....!" H 2
Q
PARM ;EP
;IHS/DSD/ENM 02/04/97 MODULE FROM APSPLBL FOR SUMMARY LBLS
;SET LBL WTH/LN/MAR & GET DATA FROM FILE #9009033
S X=$S($D(^APSPCTRL(PSOSITE,0)):^(0),1:""),PSZW=$P(X,U,14),PSZL=$P(X,U,5),PSZB=$P(X,U,6),PSZE=$P(X,U,7),PSZK=$P(X,U,9),PSZTAB=$P(X,U,13) ;IHS/DSD/ENM 08/01/96
Q
APSPSLBL ;IHS/DSD/JCM/ENM - IHS SUMMARY LABEL;17-Jan-2006 09:36;SM
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1003,1004**;09/03/97
+2 ;
+3 ;THIS ROUTINE DOES THE PRINTING OF THE REFILL OR PARTIAL
+4 ;SUMMARY LABEL TO BE PLACED IN THE PATIENTS CHART IF THIS SITE
+5 ;PARAMETER HAS BEEN CHOSEN. PLEASE BE SURE THAT THE ESCAPE SEQUENCES
+6 ;FOR YOUR PRINTER HAVE BEEN ENTERED IN YOUR TERMINAL TYPE FILE FOR
+7 ;CONDENSED PRINT AND A SOFT RESET OR 10,12 PITCH.
+8 ;
+9 ; Modified - IHS/CIA/PLS - 01/21/04, 03/08/04, 07/27/04, 08/08/2005
EP ;IHS/DSD/ENM 11/09/94 ENTRY POINT FOR SUM OPT
+1 NEW APSPZZN,ARRAY,APSPFLG,PSODFN,PSZW,PSZL,PSZB,PSZE,PSZK,PSZTAB
+2 NEW APSPQFLG,APSPEDT,PSODFN,AUPDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX
+3 NEW PSOLIST,PSOSD,PSOOPT,APSPID,PSONUM,PSOSD,PSZB,PSZDRUG,PSZE
+4 ;N APSPID,APSHRN,Y
+5 ;IHS/CIA/PLS - 08/08/2005
NEW APSPID,APSHRN,Y,APSPZDT
+6 IF '$DATA(PSOPAR)
DO ^PSOLSET
+7 SET APSPQFLG=0
SET APSPEDT=0
+8 DO PARM
+9 DO PAT^APSPNUM
+10 IF '$DATA(PSODFN)
QUIT
EPP ;
+1 DO PROFILE^PSORX1
+2 ;USED IN PSOLIST
SET APSPID=1
+3 SET PSOOPT=-1
SET PSONUM="LIST"
DO EN^APSPNUM
+4 IF $GET(Y(1))']""
DO EMSG
DO EOJ
QUIT
+5 IF Y["^"
GOTO EP
DEV ;
+1 SET %ZIS="QM"
+2 SET %ZIS("A")="Enter SUMMARY Device: "
SET IOP=$GET(PSOLAP)
DO ^%ZIS
+3 IF POP
GOTO EOJ
+4 IF $DATA(IO("Q"))
IF IO=IO(0)
Begin DoDot:1
+5 WRITE !!,"Sorry, you cannot queue to your screen or to a slave printer.",!
+6 KILL IO("Q")
DO ^%ZISC
End DoDot:1
GOTO DEV
+7 IF $DATA(IO("Q"))
Begin DoDot:1
+8 SET ZTRTN="EP1^APSPSLBL"
SET ZTIO=ION
+9 FOR G="PSOSITE","PSOPAR","%APSITE","PRF","PSZW","PSZK","PSZE","PSZL","PSZTAB","PSZB","PSONUM","PSOLIST(1)"
IF $DATA(@G)
SET ZTSAVE(G)=""
+10 SET ZTDESC="Outpatient Pharm Summary Label"
+11 DO ^%ZTLOAD
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 DO EP1
End DoDot:1
EXIT QUIT
EP1 ;INITIALIZE
+1 IF '$GET(PSOLIST(1))
QUIT
+2 NEW APSP,APSPN,APSPD,APSPS,APSPQ,APSPF,APSPZ,N
+3 FOR APSPZ=1:1
SET APSPRX=$PIECE(PSOLIST(1),",",APSPZ)
IF APSPRX=""
QUIT
SET N=APSPZ
DO ESET
+4 DO EP2
DO EOJ
+5 QUIT
ESET ;
+1 SET APSP=^PSRX(APSPRX,0)
SET APSPN=$PIECE(APSP,U,2)
SET APSPD=$PIECE(APSP,U,6)
SET APSPS=$PIECE(^PSRX(APSPRX,"SIG"),"^",1)
SET APSPQ=$PIECE(APSP,U,7)
SET APSPF=$PIECE(^PSRX(APSPRX,2),U,2)
+2 ;
+3 ; dmh added this next SIG change because orders put in sometimes
+4 ; set the sig in SIG1 wp field.....6/20/2002
+5 ;dmh 6/20/2002
IF APSPS=""
SET APSPS=$GET(^PSRX(APSPRX,"SIG1",1,0))
+6 ;
+7 ;IHS/DSD/ENM 02/05/97 GET SITE NUMBER FROM SITE FILE
SET APSXPS=$SELECT($DATA(^PS(59,PSOSITE,0)):^(0),1:"")
SET APSNBR=$PIECE(APSXPS,"^",6)
+8 ;IHS/DSD/ENM 02/05/97
SET PNM=$PIECE(^DPT(APSPN,0),U)
SET PSZDRUG=$PIECE(^PSDRUG(APSPD,0),U)
SET APSHRN=$SELECT($GET(^AUPNPAT(APSPN,41,APSNBR,0)):$PIECE(^(0),U,2),1:"")
+9 SET ARRAY(N)=$EXTRACT(PNM,1,PSZW-8)_"^"_APSPRX_"^"_PSZDRUG_"^"_APSPS_"^"_APSPQ_"^"_APSPF_"^"_APSHRN
+10 QUIT
+11 ;
EP2 ;EP
+1 NEW AAPSITE,PSZCW,PSZCTAB,PZX,PSZW,PSZL,PSZB,PSZE,PSZK,PSZTAB
+2 NEW FDT,NUM,PSOZSLBL,PSZCTAB,QTY,SIG,PSZZL,E,L,LENGTH
+3 NEW APSP,APSPD,PSZE
+4 DO PARM
+5 IF $GET(APSPZZN)]""
SET N=APSPZZN
+6 SET PZX=N
SET NUM=1
SET C=0
SET FDT=$PIECE(ARRAY(N),"^",6)
+7 SET AAPSITE=^APSPCTRL(PSOSITE,0)
+8 SET PSOZSLBL("COPIES")=$SELECT($PIECE(AAPSITE,"^",36)]"":$PIECE(AAPSITE,"^",36),1:1)
+9 ;
+10 ; THIS SETS THE NUMBER OF LINES TO PRINT
SET PSZZL=PSZL-1
+11 ;AFTER THE PATIENTS NAME AND DATE IS PRINTED
+12 ;IHS/DSD/ENM 08/01/96
SET PSZCW=$PIECE(^APSPCTRL(PSOSITE,0),"^",14)
+13 ;IHS/DSD/ENM 08/01/96
SET PSZCTAB=$PIECE(^APSPCTRL(PSOSITE,0),"^",13)
+14 IF PSZCW<PSZW
SET PSZCW=PSZW*1.6\1
+15 ;THE ABOVE LINES SETS MY COMPRESSED LABEL WIDTH AND
+16 ;MY COMPRESSED LEFT MARGIN IF NOT ALREADY SET IN
+17 ;THE IHS SITE PARAMETERS
+18 ;
+19 SET IOP=$GET(PSOLAP)
DO ^%ZIS
USE IO
+20 ;
+21 IF $EXTRACT(IOST,1,2)="P-"
IF $DATA(^%ZIS(2,IOST(0),12.1))#2
IF ^(12.1)]""
IF $DATA(^%ZIS(2,IOST(0),6))#2
IF $PIECE(^(6),U,1)]""
WRITE @($PIECE(^%ZIS(2,IOST(0),12.1),U,1))
+22 ;THE ABOVE LINE CHECKS TO SEE IF WE ARE USING A TERMINAL OR
+23 ;PRINTER AND IF ESCAPE CODES ARE SET UP IN TERMINAL TYPE FILE
+24 ;IHS/DSD/ENM/POC 05/11/98 NEXT THREE LINES
+25 ;
+26 FOR PSOZSLBL("I")=1:1:PSOZSLBL("COPIES")
Begin DoDot:1
+27 ;IHS/DSD/ENM/POC 05/11/98 ADDED PZX AND NUM
SET PZX=N
SET NUM=1
DO BEGIN
SET C=0
End DoDot:1
+28 DO FEED
+29 ;IHS/DSD/ENM 07/31/96
IF $GET(PSOFROM)]""
DO EOJ
+30 QUIT
BEGIN ;
+1 ;THIS SETS MY LINE FEEDS AT BEGINNING OF LABEL
FOR I=1:1:PSZB
WRITE !
+2 ;
+3 ;PATIENTS NAME & DATE OF ISSUE
+4 WRITE !,?(PSZCTAB),$PIECE(ARRAY(N),"^",1)_" : "_APSHRN_" "
+5 ; Display Last Fill Date
IF $GET(APSPID)]""
WRITE ?(PSZCTAB+PSZCW-9),+$EXTRACT(APSPEDT,4,5),"-",$EXTRACT(APSPEDT,6,7),"-",$EXTRACT(APSPEDT,2,3)
GOTO ZZL
+6 WRITE ?(PSZCTAB+PSZCW-9),+$EXTRACT(FDT,4,5),"-",$EXTRACT(FDT,6,7),"-",$EXTRACT(FDT,2,3)
+7 ;
ZZL ;LABEL INFORMATION
+1 FOR N=NUM:1:PZX
DO LABEL
SET C=C+1
IF C=PSZZL
QUIT
+2 ;
+3 ; Set at Top of Form
FOR I=1:1:PSZE+(PSZZL-C)
WRITE !
+4 IF $DATA(ARRAY(N+1))
SET C=0
SET NUM=N+1
GOTO BEGIN
+5 QUIT
+6 ;
FEED IF $DATA(PSZK)
IF PSZK
SET L=PSZL+PSZE+PSZB*PSZK
FOR I=1:1:L
WRITE !
+1 ;THE ABOVE LINE ACTS AS A FORM FEED WHERE PSZK
+2 ;EQUALS THE NUMBER OF FORM FEEDS
+3 QUIT
+4 ;
EOJ ;
+1 IF $EXTRACT(IOST,1,2)="P-"
IF $DATA(^%ZIS(2,IOST(0),6))#2
IF $PIECE(^(6),U,1)]""
WRITE @($PIECE(^%ZIS(2,IOST(0),6),U,1))
+2 DO ^%ZISC
+3 USE IO
+4 QUIT
LABEL ;
+1 SET LENGTH=$LENGTH($PIECE(ARRAY(N),"^",3,5))+1
+2 ;
+3 ;Truncates Drug Name if needed.
SET DRUG=$EXTRACT($PIECE(ARRAY(N),"^",3),1,PSZCW-5)
+4 ;
+5 ;POSITION WHERE SIG SHOULD PRINT
SET E=PSZCW-$LENGTH(DRUG)-2
+6 ;
+7 ;THE QUANTITY ISSUED
SET QTY=$PIECE(ARRAY(N),"^",5)
+8 ;
+9 SET SIG=$EXTRACT($PIECE(ARRAY(N),"^",4),1,PSZCW-$LENGTH(QTY)-2+E)
+10 ;THE ABOVE LINE SETS THE VALUE AND MAX LENGTH OF SIG
+11 ;
+12 IF LENGTH'>PSZCW
WRITE !,?(PSZCTAB),DRUG," ",SIG,?(PSZCTAB+PSZCW-$LENGTH(QTY)),QTY
QUIT
+13 ;THE ABOVE LINE PRINTS DRUG,SIG,QTY ON ONE LINE IF IT WILL FIT
+14 ;
+15 ;MAKES SURE THERE ARE TWO
IF C=(PSZZL-1)
SET N=N-1
WRITE !
QUIT
+16 ;LINES AVAILABLE TO PRINT ON AND RESETS N TO CORRECT VALUE
+17 ; AND DOES A LINE FEED IF NOT
+18 ;
+19 ;FIRST LINE
WRITE !,?(PSZCTAB),DRUG," ",$EXTRACT(SIG,1,E)
+20 ;
+21 IF $EXTRACT(SIG,E+1)'=" "
IF $EXTRACT(SIG,E+1)'=""
WRITE "-"
+22 ;
+23 WRITE !,?(PSZCTAB),$EXTRACT(SIG,E+1,99)
+24 WRITE ?(PSZCTAB+PSZCW-$LENGTH(QTY)),QTY
+25 ;THE ABOVE TWO LINES PRINT THE SECOND LINE
+26 ;
+27 SET C=C+1
+28 ;
+29 QUIT
EMSG ;IHS/DSD/ENM 01/29/97
+1 WRITE !,"No Rx's found for this date....!"
HANG 2
+2 QUIT
PARM ;EP
+1 ;IHS/DSD/ENM 02/04/97 MODULE FROM APSPLBL FOR SUMMARY LBLS
+2 ;SET LBL WTH/LN/MAR & GET DATA FROM FILE #9009033
+3 ;IHS/DSD/ENM 08/01/96
SET X=$SELECT($DATA(^APSPCTRL(PSOSITE,0)):^(0),1:"")
SET PSZW=$PIECE(X,U,14)
SET PSZL=$PIECE(X,U,5)
SET PSZB=$PIECE(X,U,6)
SET PSZE=$PIECE(X,U,7)
SET PSZK=$PIECE(X,U,9)
SET PSZTAB=$PIECE(X,U,13)
+4 QUIT
