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

APSEPPIM.m

Go to the documentation of this file. 
  1. APSEPPIM ;IHS/ASDS/ENM/POC - PRINTS THE PATIENT MEDICATION SHEETS ;16-Jun-2009 13:30;SM
  1.  ;;7.0;IHS PHARMACY MODIFICATIONS;**1003,1007,1008**;Sep 23, 2004
  1.  ; Modified - IHS/CIA/PLS - 02/18/04 - NRNDC+2
  1.  ;                          07/24/05 - PMI+3
  1.  ;            IHS/MSC/PLS - 08/19/08 - Line EN1+8
  1.  ;                          03/16/09 - Modified to support VistA PMI information
  1. EN ;EP - NORMAL ENTRY POINT FROM APSPNE4 PRINT LINE
  1.  U IO(0)
  1.  I '$D(^PS(50.621))!'$D(^PS(50.622)) D  Q
  1.  .W !,"NDF Patient Medication Instruction Sheets data has not been installed",!!
  1.  ;
  1.  N APSPQ,PSNLANG,APSPNUM,%ZIS,ZTSAVE,LP
  1.  ;
  1. LANG ;EP
  1.  S PSNLANG=$$GET1^DIQ(59.7,1,14,"I")
  1.  S PSNLANG=$S(PSNLANG:PSNLANG,1:1)  ;Default to English if not defined
  1.  S PSNLANG=$$DIR^APSPUTIL("S^1:English;2:Spanish","Select Language",PSNLANG,,.APSPQ)
  1.  Q:'PSNLANG
  1.  ;
  1. COPIES ;EP
  1.  S APSPNUM=$$DIR^APSPUTIL("N^1:10:0","How many copies",1,,,.APSPQ)
  1.  Q:'APSPNUM
  1.  D DEV
  1.  Q
  1. DEV ;
  1.  F LP="PPL","APSPCPP","PSNLANG","APSPNUM" S ZTSAVE(LP)=""
  1.  S:$L($G(APSPCPP)) %ZIS("B")=APSPCPP
  1.  D EN^XUTMDEVQ("PMI^APSEPPIM","Print Medication Information Sheets",.ZTSAVE,.%ZIS)
  1.  I POP D  Q
  1.  .W !,"No device selected and no PMIs printed.",!
  1.  Q
  1.  ;
  1. EN1 ;EP  - 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 PT^APSPNUM   ; IHS/BAO/DMH - 03/01/2002
  1.  ; IHS/MSC/PLS - 08/19/08
  1.  ;Q:'PSODFN
  1.  Q:'$D(PSODFN)
  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
  1.  Q:'$D(PPL)  ;Nothing to print
  1.  N APSQ,APSQIEN,DRG,APSQRXN,APSDOC,APSDNAM   ;IHS/CIA/PLS - 07/24/2005
  1.  N PSNDFN,PSNTYPE,NUM,PSRX,PSODFN,PSNDF,PSNPN,PSNGCN,APSI
  1.  S NUM=APSPNUM
  1.  S PSNTYPE=$S(PSNLANG=1:2,1:5)
  1.  F APSI=1:1 S APSQIEN=$P(PPL,",",APSI) Q:'APSQIEN  D
  1.  .S DRG=+$P(^PSRX(APSQIEN,0),U,6)
  1.  .Q:'DRG
  1.  .S APSQRXN=+^PSRX(APSQIEN,0)
  1.  .S PSRX=$P(APSQRXN,U)  ; Prescription Number
  1.  .S APSDOC=$P(^PSRX(APSQIEN,0),U,4),APSDNAM=$P(^VA(200,APSDOC,0),U)
  1.  .S (PSNDFN,PSODFN)=$P(^PSRX(APSQIEN,0),U,2)
  1.  .S PSNDF=$G(^PSDRUG(DRG,"ND"))
  1.  .S PSNPN=+$P(PSNDF,U,3),PSNDF=+PSNDF
  1.  .S PSNGCN=$P($G(^PSNDF(50.68,PSNPN,1)),U,5)
  1.  .S:'$L(PSNGCN) PSNGCN=" "
  1.  .D DOONE^PSNPPIP
  1.  ;
  1. END ;EP
  1.  D ^%ZISC
  1.  S:$D(ZTQUEUED) ZTREQ="@"
  1.  Q
  1. NRNDC ;IHS/ASD/ENM 05/31/01 - GET LAST REFILL NDC OR NEW RX NDC
  1.  S APSPIRN=$O(^PSRX(APSQIEN,1,"A"),-1)
  1.  ; IHS/CIA/PLS - 02/18/04 - Changed lookup for refill NDC to use extrinsic function
  1.  ;I +APSPIRN S APSPNDC=$P($G(^PSRX(APSQIEN,1,APSPIRN,0)),"^",13) Q
  1.  ;S APSPNDC=$P($G(^PSRX(APSQIEN,2)),"^",7)
  1.  I +APSPIRN S APSPNDC=$$NDCVAL^APSPFUNC(APSQIEN,APSPIRN)
  1.  E  S APSPNDC=$$NDCVAL^APSPFUNC(APSQIEN)
  1.  Q
  1.  ;
  1. PAUSE ;EP
  1.  N QQ
  1.  S QQ=$$DIR^APSPUTIL("FO","Press <return> to continue.")
  1.  Q