APSEPPIM ;IHS/ASDS/ENM/POC - PRINTS THE PATIENT MEDICATION SHEETS ;16-Jun-2009 13:30;SM
;;7.0;IHS PHARMACY MODIFICATIONS;**1003,1007,1008**;Sep 23, 2004
; Modified - IHS/CIA/PLS - 02/18/04 - NRNDC+2
; 07/24/05 - PMI+3
; IHS/MSC/PLS - 08/19/08 - Line EN1+8
; 03/16/09 - Modified to support VistA PMI information
EN ;EP - NORMAL ENTRY POINT FROM APSPNE4 PRINT LINE
U IO(0)
I '$D(^PS(50.621))!'$D(^PS(50.622)) D Q
.W !,"NDF Patient Medication Instruction Sheets data has not been installed",!!
;
N APSPQ,PSNLANG,APSPNUM,%ZIS,ZTSAVE,LP
;
LANG ;EP
S PSNLANG=$$GET1^DIQ(59.7,1,14,"I")
S PSNLANG=$S(PSNLANG:PSNLANG,1:1) ;Default to English if not defined
S PSNLANG=$$DIR^APSPUTIL("S^1:English;2:Spanish","Select Language",PSNLANG,,.APSPQ)
Q:'PSNLANG
;
COPIES ;EP
S APSPNUM=$$DIR^APSPUTIL("N^1:10:0","How many copies",1,,,.APSPQ)
Q:'APSPNUM
D DEV
Q
DEV ;
F LP="PPL","APSPCPP","PSNLANG","APSPNUM" S ZTSAVE(LP)=""
S:$L($G(APSPCPP)) %ZIS("B")=APSPCPP
D EN^XUTMDEVQ("PMI^APSEPPIM","Print Medication Information Sheets",.ZTSAVE,.%ZIS)
I POP D Q
.W !,"No device selected and no PMIs printed.",!
Q
;
EN1 ;EP - ENTRY FROM MENU OPTION FOR SINGLE PATIENT
N PPL,PSOSD,DFN,APSQRXN,APSQIEN,APSQDRG,APSQ
N PSRX,PSNDFN,NAM,APSDNAM,APSDOC,APSPNDC,CR,DFN,ED,ED1,ED2,ED3,NDC,NUM
N P2,PG,PPI,PPL,PS,PSODFN,SSN,SEX,VA,VADM,XNDC
N Z,PSCNT,PSOCT,PSODTCUT,PSOERR,PSOLIST,PSOOPT,PSOSTA,RXN,STP,STR
N J,JJ,IEN,DIWI,DIW,DIWT,DN,APSPIRN,APSPZDT
N POP,VAERR,CNT,DIR,DIWTC,DOB,DRG,IOHG,DIWX,IOBS
D PT^APSPNUM ; IHS/BAO/DMH - 03/01/2002
; IHS/MSC/PLS - 08/19/08
;Q:'PSODFN
Q:'$D(PSODFN)
S PSONUM="LIST"
D EN^APSPNUM
G:'$D(PSOLIST) END
S PPL=PSOLIST(1) ;BETTER WATCH THIS AS IT CAN BE TOO LONG
G EN
;
PMI ;SET UP AND PRINT
U IO
Q:'$D(PPL) ;Nothing to print
N APSQ,APSQIEN,DRG,APSQRXN,APSDOC,APSDNAM ;IHS/CIA/PLS - 07/24/2005
N PSNDFN,PSNTYPE,NUM,PSRX,PSODFN,PSNDF,PSNPN,PSNGCN,APSI
S NUM=APSPNUM
S PSNTYPE=$S(PSNLANG=1:2,1:5)
F APSI=1:1 S APSQIEN=$P(PPL,",",APSI) Q:'APSQIEN D
.S DRG=+$P(^PSRX(APSQIEN,0),U,6)
.Q:'DRG
.S APSQRXN=+^PSRX(APSQIEN,0)
.S PSRX=$P(APSQRXN,U) ; Prescription Number
.S APSDOC=$P(^PSRX(APSQIEN,0),U,4),APSDNAM=$P(^VA(200,APSDOC,0),U)
.S (PSNDFN,PSODFN)=$P(^PSRX(APSQIEN,0),U,2)
.S PSNDF=$G(^PSDRUG(DRG,"ND"))
.S PSNPN=+$P(PSNDF,U,3),PSNDF=+PSNDF
.S PSNGCN=$P($G(^PSNDF(50.68,PSNPN,1)),U,5)
.S:'$L(PSNGCN) PSNGCN=" "
.D DOONE^PSNPPIP
;
END ;EP
D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
Q
NRNDC ;IHS/ASD/ENM 05/31/01 - GET LAST REFILL NDC OR NEW RX NDC
S APSPIRN=$O(^PSRX(APSQIEN,1,"A"),-1)
; IHS/CIA/PLS - 02/18/04 - Changed lookup for refill NDC to use extrinsic function
;I +APSPIRN S APSPNDC=$P($G(^PSRX(APSQIEN,1,APSPIRN,0)),"^",13) Q
;S APSPNDC=$P($G(^PSRX(APSQIEN,2)),"^",7)
I +APSPIRN S APSPNDC=$$NDCVAL^APSPFUNC(APSQIEN,APSPIRN)
E S APSPNDC=$$NDCVAL^APSPFUNC(APSQIEN)
Q
;
PAUSE ;EP
N QQ
S QQ=$$DIR^APSPUTIL("FO","Press <return> to continue.")
Q
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
+2 ; Modified - IHS/CIA/PLS - 02/18/04 - NRNDC+2
+3 ; 07/24/05 - PMI+3
+4 ; IHS/MSC/PLS - 08/19/08 - Line EN1+8
+5 ; 03/16/09 - Modified to support VistA PMI information
EN ;EP - NORMAL ENTRY POINT FROM APSPNE4 PRINT LINE
+1 USE IO(0)
+2 IF '$DATA(^PS(50.621))!'$DATA(^PS(50.622))
Begin DoDot:1
+3 WRITE !,"NDF Patient Medication Instruction Sheets data has not been installed",!!
End DoDot:1
QUIT
+4 ;
+5 NEW APSPQ,PSNLANG,APSPNUM,%ZIS,ZTSAVE,LP
+6 ;
LANG ;EP
+1 SET PSNLANG=$$GET1^DIQ(59.7,1,14,"I")
+2 ;Default to English if not defined
SET PSNLANG=$SELECT(PSNLANG:PSNLANG,1:1)
+3 SET PSNLANG=$$DIR^APSPUTIL("S^1:English;2:Spanish","Select Language",PSNLANG,,.APSPQ)
+4 IF 'PSNLANG
QUIT
+5 ;
COPIES ;EP
+1 SET APSPNUM=$$DIR^APSPUTIL("N^1:10:0","How many copies",1,,,.APSPQ)
+2 IF 'APSPNUM
QUIT
+3 DO DEV
+4 QUIT
DEV ;
+1 FOR LP="PPL","APSPCPP","PSNLANG","APSPNUM"
SET ZTSAVE(LP)=""
+2 IF $LENGTH($GET(APSPCPP))
SET %ZIS("B")=APSPCPP
+3 DO EN^XUTMDEVQ("PMI^APSEPPIM","Print Medication Information Sheets",.ZTSAVE,.%ZIS)
+4 IF POP
Begin DoDot:1
+5 WRITE !,"No device selected and no PMIs printed.",!
End DoDot:1
QUIT
+6 QUIT
+7 ;
EN1 ;EP - ENTRY FROM MENU OPTION FOR SINGLE PATIENT
+1 NEW PPL,PSOSD,DFN,APSQRXN,APSQIEN,APSQDRG,APSQ
+2 NEW PSRX,PSNDFN,NAM,APSDNAM,APSDOC,APSPNDC,CR,DFN,ED,ED1,ED2,ED3,NDC,NUM
+3 NEW P2,PG,PPI,PPL,PS,PSODFN,SSN,SEX,VA,VADM,XNDC
+4 NEW Z,PSCNT,PSOCT,PSODTCUT,PSOERR,PSOLIST,PSOOPT,PSOSTA,RXN,STP,STR
+5 NEW J,JJ,IEN,DIWI,DIW,DIWT,DN,APSPIRN,APSPZDT
+6 NEW POP,VAERR,CNT,DIR,DIWTC,DOB,DRG,IOHG,DIWX,IOBS
+7 ; IHS/BAO/DMH - 03/01/2002
DO PT^APSPNUM
+8 ; IHS/MSC/PLS - 08/19/08
+9 ;Q:'PSODFN
+10 IF '$DATA(PSODFN)
QUIT
+11 SET PSONUM="LIST"
+12 DO EN^APSPNUM
+13 IF '$DATA(PSOLIST)
GOTO END
+14 ;BETTER WATCH THIS AS IT CAN BE TOO LONG
SET PPL=PSOLIST(1)
+15 GOTO EN
+16 ;
PMI ;SET UP AND PRINT
+1 USE IO
+2 ;Nothing to print
IF '$DATA(PPL)
QUIT
+3 ;IHS/CIA/PLS - 07/24/2005
NEW APSQ,APSQIEN,DRG,APSQRXN,APSDOC,APSDNAM
+4 NEW PSNDFN,PSNTYPE,NUM,PSRX,PSODFN,PSNDF,PSNPN,PSNGCN,APSI
+5 SET NUM=APSPNUM
+6 SET PSNTYPE=$SELECT(PSNLANG=1:2,1:5)
+7 FOR APSI=1:1
SET APSQIEN=$PIECE(PPL,",",APSI)
IF 'APSQIEN
QUIT
Begin DoDot:1
+8 SET DRG=+$PIECE(^PSRX(APSQIEN,0),U,6)
+9 IF 'DRG
QUIT
+10 SET APSQRXN=+^PSRX(APSQIEN,0)
+11 ; Prescription Number
SET PSRX=$PIECE(APSQRXN,U)
+12 SET APSDOC=$PIECE(^PSRX(APSQIEN,0),U,4)
SET APSDNAM=$PIECE(^VA(200,APSDOC,0),U)
+13 SET (PSNDFN,PSODFN)=$PIECE(^PSRX(APSQIEN,0),U,2)
+14 SET PSNDF=$GET(^PSDRUG(DRG,"ND"))
+15 SET PSNPN=+$PIECE(PSNDF,U,3)
SET PSNDF=+PSNDF
+16 SET PSNGCN=$PIECE($GET(^PSNDF(50.68,PSNPN,1)),U,5)
+17 IF '$LENGTH(PSNGCN)
SET PSNGCN=" "
+18 DO DOONE^PSNPPIP
End DoDot:1
+19 ;
END ;EP
+1 DO ^%ZISC
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 QUIT
NRNDC ;IHS/ASD/ENM 05/31/01 - GET LAST REFILL NDC OR NEW RX NDC
+1 SET APSPIRN=$ORDER(^PSRX(APSQIEN,1,"A"),-1)
+2 ; IHS/CIA/PLS - 02/18/04 - Changed lookup for refill NDC to use extrinsic function
+3 ;I +APSPIRN S APSPNDC=$P($G(^PSRX(APSQIEN,1,APSPIRN,0)),"^",13) Q
+4 ;S APSPNDC=$P($G(^PSRX(APSQIEN,2)),"^",7)
+5 IF +APSPIRN
SET APSPNDC=$$NDCVAL^APSPFUNC(APSQIEN,APSPIRN)
+6 IF '$TEST
SET APSPNDC=$$NDCVAL^APSPFUNC(APSQIEN)
+7 QUIT
+8 ;
PAUSE ;EP
+1 NEW QQ
+2 SET QQ=$$DIR^APSPUTIL("FO","Press <return> to continue.")
+3 QUIT
