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

APSAPPIM.m

Go to the documentation of this file. 
  1. APSAPPIM ;IHS/ASDS/ENM/POC - PRINTS THE PATIENT MEDICATION SHEETS  [ 11/13/2003  4:12 PM ];09-Oct-2008 11:24;SM
  1.  ;;7.0;IHS PHARMACY MODIFICATIONS;**1007**;Sep 23, 2004
  1.  ; Modified - IHS/CIA/PLS - 01/21/04
  1.  ;            IHS/MSC/PLS - 08/19/08 - Line EN1+8
  1. EN ;EP - NORMAL ENTRY POINT FROM APSPNE4 PRINT LINE
  1.  S PSNDFN=DFN
  1. DEV ;
  1.  I $G(APSPCPP)]"" D  ;
  1.  .S APSPIEND=$O(^%ZIS(1,"B",APSPCPP,""))
  1.  .I (APSPIEND]"")&($P(^%ZIS(1,APSPIEND,0),"^",2)=0) S IOP=APSPCPP Q  ;SLAVED
  1.  .I (APSPIEND]"")&($P(^%ZIS(1,APSPIEND,0),"^",2)=IO(0)) S IOP=APSPCPP Q  ;HOME DEVICE
  1.  .S IOP="Q;"_APSPCPP Q  ;ALL OTHER
  1.  S %ZIS="Q" D ^%ZIS
  1.  I POP W !,"BUSY...WAIT A FEW MINUTES" S %=1 D YN^DICN H 5 G:%=1 DEV G END
  1.  I $D(IO("Q")) D  D ^%ZTLOAD D HOME^%ZIS K IO("Q") Q
  1.  .S ZTRTN="PMI^APSAPPIM",ZTDESC="PRINT PHARMACY PMIS"
  1.  .S ZTDTH=$H
  1.  .F I="PPL","APSPCPP","PSNDFN" S ZTSAVE(I)=""
  1.  D PMI
  1.  Q
  1.  ;
  1. EN1 ;ENTRY FROM MENU OPTION FOR SINGLE PATIENT
  1.  N PPL,PSOSD,DFN,APSQRXN,APSQIEN,APSQDRG,APSQ
  1.  N PSRX,PSNDFN,NAM,APSDNAM,APSDOC,APSPNDC,CR,DFN,ED,ED1,ED2,ED3,NDC,NUM
  1.  N P2,PG,PPI,PPL,PS,PSODFN,SSN,SEX,VA,VADM,XNDC
  1.  N Z,PSCNT,PSOCT,PSODTCUT,PSOERR,PSOLIST,PSOOPT,PSOSTA,RXN,STP,STR
  1.  N J,JJ,IEN,DIWI,DIW,DIWT,DN,APSPIRN,APSPZDT
  1.  N POP,VAERR,CNT,DIR,DIWTC,DOB,DRG,IOHG,DIWX,IOBS
  1.  D PAT^APSPNUM
  1.  Q:'$D(PSODFN)  ;IHS/MSC/PLS - 08/19/08
  1.  S PSONUM="LIST"
  1.  D EN^APSPNUM
  1.  G:'$D(PSOLIST) END
  1.  S PPL=PSOLIST(1) ;BETTER WATCH THIS AS IT CAN BE TOO LONG
  1.  G EN
  1.  ;
  1. PMI ;SET UP AND PRINT
  1.  U IO ;POC 04/10/01
  1.  I $E(IOST)="P" S APSQCOM=$P($G(^%ZIS(2,IOST(0),12.1)),"^"),APSQRSET=$P($G(^(6)),"^") W:APSQCOM]"" @APSQCOM ;COMPRESS IF A PRINTER TO 16 PITCH
  1.  Q:'$D(PPL)  ;NO RXS TO PRINT SO NO MED SHEETS TO PRINT EITHER
  1.  F I=1:1 S APSQIEN=$P(PPL,",",I) Q:'APSQIEN  D
  1.  .S APSQDRG=$P(^PSRX(APSQIEN,0),"^",6)
  1.  .Q:$$TEST(APSQDRG)
  1.  .S APSQRXN=+^PSRX(APSQIEN,0)
  1.  .S APSDOC=$P(^PSRX(APSQIEN,0),"^",4),APSDNAM=$P(^VA(200,APSDOC,0),"^",1)
  1.  .D PICK
  1.  .S APSQ(I)=PPI_"^"_APSQDRG_"^"_APSQRXN ;SO ONLY GET ONE OF SHEET EVEN IF TWO DRUGS POINT TO SAME PATIENT INFORMATION SHEET
  1.  .Q
  1.  S NUM=1
  1. PRINT S JJ=0 F  S JJ=$O(APSQ(JJ)) Q:'JJ  S PPI=$P(APSQ(JJ),"^",1),DRG=$P(APSQ(JJ),"^",2),PSRX=$P(APSQ(JJ),"^",3) D EP2^APSAPPIP
  1. END ;EP - POC 04/10/01
  1.  D ^%ZISC
  1.  S:$D(ZTQUEUED) ZTREQ="@"
  1.  Q
  1. TEST(N) ;TEST FOR ENTRY OF PATIENT MED SHEET IN ^PSPPI GLOBAL
  1.  I $S('$G(^PSDRUG(+N,"I")):1,DT'>^("I"):1,1:0) Q 0
  1.  E  Q 1 ;1=NO GO
  1.  Q
  1. PICK ;select a drug from file 50
  1.  I '$D(APSQDRG) Q
  1.  I '$D(^APSAPPI) W !,"Patient Medication Instruction Sheets data has not been installed",!! G EXIT
  1.  S DRG=APSQDRG
  1.  S X=$P($G(^PSDRUG(DRG,2)),U,4)
  1.  I X="" S PPI=.5 Q
  1.  D ^APSPMDD S NDC=X D ECK  ;GET NDC AND REMOVE DASHES
  1.  I PPI=""!(PPI=0) S PPI=.5,P2=1
  1.  Q
  1. ECK ;
  1.  S RN=0,PPI=0,XNDC=0 F  S XNDC=$O(^APSAMDF("B",XNDC)) Q:XNDC=""  I XNDC=NDC  D  Q  ;
  1.  .S RN=$O(^APSAMDF("B",XNDC,RN))
  1.  .S PPI=^APSAMDF(RN,3)
  1.  .I $G(^APSAPPI(PPI,0))="" S PPI=.5
  1. EXIT Q