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

APSPDSC.m

Go to the documentation of this file. 
  1. APSPDSC ; IHS/DSD/ENM - PRINT DISCHARGE SHEET ;29-Jan-2004 08:56;PLS
  1.  ;;7.0;IHS PHARMACY MODIFICATIONS;;09/03/97
  1.  ; Modified - IHS/CIA/PLS - 01/14/04
  1.  D INIT
  1. START D PAT G END:APSPDSC("FLG")
  1.  D ^PSOBUILD
  1.  S APSPDSC("ST")="ACTIVE" D ^PSODSPL
  1.  I $G(PSOSD)']"" S APSPDSC("FLG")=1 G END ;IHS/DSD/ENM 08/14/96
  1.  D ASK G APSPDSC:APSPDSC("FLG")=2
  1.  ;IHS/ITSC/ENM 01/24/03 NEXT 2 LINES COPIED/MOD
  1.  D COPIES I APSPDSC("FLG")=4 D EOJ G APSPDSC  ;IHS/DSD/ENM/POC 08/10/02
  1.  D DEVICE I APSPDSC("FLG")=3 D EOJ G APSPDSC  ;IHS/DSD/ENM/POC 08/10/02
  1.  D ^APSPDSC1
  1. END D EOJ
  1.  Q
  1.  ;-----------------------------------------------
  1. INIT ;
  1.  S APSPDSC("FLG")=0
  1.  S X1=DT,X2=-45 D C^%DTC S PSEED=X-1 K X,X1,X2
  1.  K PSOSD,PSODFN S PSFROM="N",(PSOSD,APSPDSC("FLG"))=0
  1.  S PSOOPT=1
  1.  S APSPAGE=1
  1.  S Y=DT X ^DD("DD") S APSPDSC("DATE")=Y
  1.  I $D(DUZ(2)),$D(^DIC(4,DUZ(2),0)),$P(^(0),U,1)]"" S APSPDSC("FAC")=$P(^(0),U,1)
  1.  Q
  1. PAT ;
  1.  S DIC="^AUPNPAT(",DIC(0)="QEAM" D ^DIC K DIC,DR
  1.  I "^"[X!'$T S APSPDSC("FLG")=1 G PATX
  1.  G PAT:+Y<0
  1.  I '$D(^PS(55,+Y,"P")) W !?20,"NO PHARMACY INFORMATION" G PAT
  1.  S PSODFN=+Y
  1.  S:$D(^DPT(PSODFN,0))#2 APSPDSC("NAME")=$P(^(0),U,1)
  1. PATX ;
  1.  Q
  1. ASK ;
  1.  K X,DIR
  1.  S DIR("A")="CHOOSE FROM ",DIR("?")="^D QUES^APSPDSC",DIR(0)="L^1:"_$G(APSPZDT) D ^DIR K DIR
  1.  I $D(DTOUT)!$D(DUOUT)!$D(DIRUT) S APSPDSC("FLG")=2 G ASKX
  1.  S PSRXS=Y
  1.  I "^"[PSRXS S APSPDSC("FLG")=2 G ASKX
  1.  I PSRXS["-" D QUES,^PSODSPL G ASK ;IHS/DSD/ENM 6.29.95
  1.  I PSRXS'?1N.E!(+PSRXS>PSOSD) D QUES D ^PSODSPL G ASK
  1.  ;IHS/DSD/ENM 6/09/97 $ NEXT REMOVED FM NEXT LINE 'APS3 ADDED
  1.  ;F APS=1:1 S APS1=$P(PSRXS,",",APS) Q:APS1=""  S APS3="" F APS2=1:1:APS1 S APS3=$O(PSOSD(APS3)) Q:APS3=""  I APS2=APS1 W !,APS3 S APSX=$S($D(APSX):APSX_","_$P(+PSOSD(APS3),U,1),1:$P(+PSOSD(APS3),U,1))
  1.  ; Restrict display to ACTIVE scripts
  1.  ; v7.0 PSOBUILD returns array with 2 subscripts (1st=status, 2nd=drug name)
  1.  F APS=1:1 S APS1=$P(PSRXS,",",APS) Q:APS1=""  D
  1.  .S APS3="" F APS2=1:1:APS1 D
  1.  ..S APS3=$O(PSOSD("ACTIVE",APS3)) Q:APS3=""  D
  1.  ...I APS2=APS1 D
  1.  ....W !,APS3 S APSX=$S($D(APSX):APSX_","_$P(+PSOSD("ACTIVE",APS3),U,1),1:$P(+PSOSD("ACTIVE",APS3),U,1))
  1. ASKX ;Exit for ASK subroutine
  1.  K APS,APS1,APS2,APS3
  1.  Q
  1. QUES ;
  1.  W !?5,"Enter the item #(s) or RX #(s) you wish to print seperated by commas or dash."
  1.  W !?5,"For example: 1,2,5 or 1-5 or 123456,33254A,232323B."
  1.  W !?5,"Do not enter the same number twice, duplicates are not allowed."
  1.  Q
  1. DEVICE ;
  1.  S %ZIS="QM"
  1.  S %ZIS("A")="Please enter PATIENT INSTRUCTION SHEET device: " D ^%ZIS
  1.  I POP K POP S APSPDSC("FLG")=3 G DEVICEX
  1.  I $D(IO("Q")),IO=IO(0) W !!,"Sorry, you cannot queue to your screen or to a slave printer.",! K IO("Q") G DEVICE
  1.  G DEVICEX:'$D(IO("Q"))
  1.  K ZTSAVE
  1.  F APSF="APSPAGE","APSX","APSPDSC(""NAME"")","APSPDSC(""DATE"")","APSPDSC(""FAC"")","APSPDSC(""COPIES"")","IOM","PSODFN" S ZTSAVE(APSF)=""
  1.  S ZTRTN="^APSPDSC1",ZTIO=ION
  1.  S ZTDESC="MEDICATION INSTRUCTIONS"
  1.  D ^%ZTLOAD
  1.  S APSPDSC("FLG")=3
  1. DEVICEX ;
  1.  Q
  1. COPIES ;
  1.  S DIR(0)="NO^1:10:0"
  1.  S DIR("B")=1,DIR("A")="Number of copies:"
  1.  D ^DIR
  1.  I $D(DIRUT)!($D(DTOUT)) S APSPDSC("FLG")=4 G COPIESX
  1.  S APSPDSC("COPIES")=$S(+Y>0:+Y,1:1)
  1. COPIESX ;
  1.  K DIR
  1.  Q
  1. EOJ ;EP
  1.  K %ZIS,APS,APS1,APS2,APS3,APSPDSC,APSF,APSPAGE,APSX,DIC,PSOSD,PSODFN,PSEED
  1.  K PSFROM,PSOSD,PSRXS,X,X1,X2,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,POP,IO("Q")
  1.  K DRG,DRX0,PS,PSC,PSISD,PSLC,REFRM,RX0,RX2,RX3,ST,ST0,STAR,Z0,Z1,W
  1.  K DIR,DIRUT,DTOUT
  1.  Q