Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APSPSLBL

APSPSLBL.m

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