APSEPPIP ;IHS/ASDS/ENM - Print a Medication Instruction Sheet [ 06/11/2001 1:31 PM ]
;;6.1;IHS PHARMACY MODIFICATIONS;**1**;03/16/01
;BIR/DMA-print a medication instruction sheet ;15 Jan 97 / 2:19 PM
;
PICK ;select a drug from file 50
S NUM=1,PG=1
I $D(PSNDRUG) Q
I '$D(^APSAPPI) W !,"Patient Medication Instruction Sheets data has not been installed",!! Q
S DIC=50,DIC(0)="AEQMZ",DIC("S")="D DICS^APSEPPIP" D ^DIC K DIC Q:Y<0 S DRG=+Y
S X=$P($G(^PSDRUG(DRG,2)),U,4) Q:X="" D ^APSPMDD S NDC=X D ECK I PPI=""!(PPI=0) S PPI=.5,P2=1 ;GET NDC AND REMOVE DASHES
I XNDC="" S PPI=.5,P2=1
EP2 ;EP FROM APSEPPIM
I PPI=.5 S P2=1 D NOSH Q
S NUM=1 D PRINT1
;D QUIT
Q
ECK ;
S RN=0,PPI=0,XNDC=0 F S XNDC=$O(^APSAMDF("B",XNDC)) Q:XNDC="" I XNDC=NDC D Q ;
.S RN=$O(^APSAMDF("B",XNDC,RN))
.S PPI=^APSAMDF(RN,3)
.I $G(^APSAPPI(PPI,0))="" S PPI=.5
Q
PRINT1 ;
K DRUG I $G(PSNTRADE)'="" S DRUG=PSNTRADE
I '$D(DRUG) S DRUG=$P(^PSDRUG(DRG,0),"^"),X=$G(^("ND")),J=+X,K=+$P(X,"^",3),X=$P($G(^PSNDF(J,5,K,2)),"^") I X]"" S DRUG=X
S QUIT=0 F J=1:1:NUM Q:QUIT S PG=1 D HEAD Q:QUIT F K=0:0 S K=$O(^APSAPPI(PPI,1,K)) Q:'K D WRITE I $Y+4>IOSL D HEAD Q:QUIT
Q:QUIT
D DISC
K DRUG
Q
WRITE ;
S TXT=^APSAPPI(PPI,1,K,0)
I TXT["GENERIC NAME" W !,?8,TXT Q
I TXT[": " W !!,?8,TXT Q
W !,?8,TXT
Q
NOSH ;IF NO MONOGRAPH, PRINT A GENERIC SHEET
;S PPI=.5,P2=1
K DRUG I $G(PSNTRADE)'="" S DRUG=PSNTRADE
I '$D(DRUG) S DRUG=$P(^PSDRUG(DRG,0),"^"),X=$G(^("ND")),J=+X,K=+$P(X,"^",3),X=$P($G(^PSNDF(J,5,K,2)),"^") I X]"" S DRUG=X
;S QUIT=0 F J=1:1:NUM Q:QUIT S PG=1 D HEAD F K=0:0 S K=$O(^APSAPPI(PPI,P2,K)) Q:'K D WRITE1 I $Y+4>IOSL D HEAD Q:QUIT
S QUIT=0 F J=1:1:NUM Q:QUIT S PG=1 D HEAD Q:QUIT F K=0:0 S K=$O(^APSAPPI(PPI,P2,K)) Q:'K D WRITE1 I $Y+4>IOSL D HEAD Q:QUIT
Q:QUIT
D DISC
K DRUG
Q
WRITE1 ;
;S TXT=^APSAPPI(.5,1,K,0)
S TXT=^APSAPPI(PPI,P2,K,0)
I TXT["GENERIC NAME" W !,?8,TXT Q
I TXT[": " W !!,?8,TXT Q
W !,?8,TXT
Q
DISC ;PRINT TRAILER COPYRIGHT AND DISCLAIMER ON MONOGRAPH
S CR=$P(^APSAPPI(.5,0),U),ED=$P(^APSAPPI(.5,0),U,5),ED1=$E(ED,1,4),ED2=$E(ED,5,6)
S ED3=$S(ED2="01":"JANUARY",ED2="02":"FEBRUARY",ED2="03":"MARCH",ED2="04":"APRIL",ED2="05":"MAY",ED2="06":"JUNE",ED2="07":"JULY",ED2="08":"AUGUST",ED2="09":"SEPTEMBER",ED2="10":"OCTOBER",ED2="11":"NOVEMBER",ED2="12":"DECEMBER",1:"")
S PPI=.5,P2=2
W !!,?12,CR I $Y+4>IOSL D HEAD Q:QUIT
W !,?16,"Information Expires ",ED3_" "_ED1,! I $Y+4>IOSL D HEAD Q:QUIT
;add line to print copyright
F K=0:0 S K=$O(^APSAPPI(PPI,2,K)) Q:'K D WRITE1 I $Y+4>IOSL D HEAD Q:QUIT
S ACK=$P(^APSAPPI(.5,3,1,0)," ",1) W !!,?16,ACK ;ACKNOWLEDGMENT PRINT
;I $Y+4>IOSL D HEAD Q:QUIT
Q
;
;S DIR(0)="N^1:100:0",DIR("A")="How many copies? ",DIR("B")=1 D ^DIR K DIR I $D(DIRUT) Q
;S NUM=Y
Q
PRINT ;
;I $D(PSNDFN) S DFN=PSNDFN,NAM=$P(^DPT(DFN,0),"^") D DEM^VADPT
S QUIT=0 F J=1:1:NUM Q:QUIT S PG=1 D HEAD Q:QUIT F K=1:1 Q:'$D(^TMP($J,"W",K)) W ^(K),! I $Y+4>IOSL D HEAD Q:QUIT
S:$D(ZTQUEUED) ZTREQ="@" D ^%ZISC Q
HEAD ;
I $D(PSNDFN) S DFN=PSNDFN,NAM=$P(^DPT(DFN,0),"^") D DEM^VADPT
I PG>1,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR I 'Y S QUIT=1 Q
W:$Y @IOF W "DRUG NAME: ",DRUG,?45,"Rx Number: "_$G(PSRX),?70,"Page ",PG S PG=PG+1
I $D(NAM) W !,"Patient: ",NAM,?35,"Doctor: "_APSDNAM,?64,$$HTE^XLFDT(+$H),!
;W !,?2,"DOCTOR: ",?15,APSDNAM,!!
Q
DICS ; screen out inactives DRUG entries in file 50
I $S('$G(^PSDRUG(+Y,"I")):1,DT'>^("I"):1,1:0)
Q
APSEPPIP ;IHS/ASDS/ENM - Print a Medication Instruction Sheet [ 06/11/2001 1:31 PM ]
+1 ;;6.1;IHS PHARMACY MODIFICATIONS;**1**;03/16/01
+2 ;BIR/DMA-print a medication instruction sheet ;15 Jan 97 / 2:19 PM
+3 ;
PICK ;select a drug from file 50
+1 SET NUM=1
SET PG=1
+2 IF $DATA(PSNDRUG)
QUIT
+3 IF '$DATA(^APSAPPI)
WRITE !,"Patient Medication Instruction Sheets data has not been installed",!!
QUIT
+4 SET DIC=50
SET DIC(0)="AEQMZ"
SET DIC("S")="D DICS^APSEPPIP"
DO ^DIC
KILL DIC
IF Y<0
QUIT
SET DRG=+Y
+5 ;GET NDC AND REMOVE DASHES
SET X=$PIECE($GET(^PSDRUG(DRG,2)),U,4)
IF X=""
QUIT
DO ^APSPMDD
SET NDC=X
DO ECK
IF PPI=""!(PPI=0)
SET PPI=.5
SET P2=1
+6 IF XNDC=""
SET PPI=.5
SET P2=1
EP2 ;EP FROM APSEPPIM
+1 IF PPI=.5
SET P2=1
DO NOSH
QUIT
+2 SET NUM=1
DO PRINT1
+3 ;D QUIT
+4 QUIT
ECK ;
+1 ;
SET RN=0
SET PPI=0
SET XNDC=0
FOR
SET XNDC=$ORDER(^APSAMDF("B",XNDC))
IF XNDC=""
QUIT
IF XNDC=NDC
Begin DoDot:1
+2 SET RN=$ORDER(^APSAMDF("B",XNDC,RN))
+3 SET PPI=^APSAMDF(RN,3)
+4 IF $GET(^APSAPPI(PPI,0))=""
SET PPI=.5
End DoDot:1
QUIT
+5 QUIT
PRINT1 ;
+1 KILL DRUG
IF $GET(PSNTRADE)'=""
SET DRUG=PSNTRADE
+2 IF '$DATA(DRUG)
SET DRUG=$PIECE(^PSDRUG(DRG,0),"^")
SET X=$GET(^("ND"))
SET J=+X
SET K=+$PIECE(X,"^",3)
SET X=$PIECE($GET(^PSNDF(J,5,K,2)),"^")
IF X]""
SET DRUG=X
+3 SET QUIT=0
FOR J=1:1:NUM
IF QUIT
QUIT
SET PG=1
DO HEAD
IF QUIT
QUIT
FOR K=0:0
SET K=$ORDER(^APSAPPI(PPI,1,K))
IF 'K
QUIT
DO WRITE
IF $Y+4>IOSL
DO HEAD
IF QUIT
QUIT
+4 IF QUIT
QUIT
+5 DO DISC
+6 KILL DRUG
+7 QUIT
WRITE ;
+1 SET TXT=^APSAPPI(PPI,1,K,0)
+2 IF TXT["GENERIC NAME"
WRITE !,?8,TXT
QUIT
+3 IF TXT[": "
WRITE !!,?8,TXT
QUIT
+4 WRITE !,?8,TXT
+5 QUIT
NOSH ;IF NO MONOGRAPH, PRINT A GENERIC SHEET
+1 ;S PPI=.5,P2=1
+2 KILL DRUG
IF $GET(PSNTRADE)'=""
SET DRUG=PSNTRADE
+3 IF '$DATA(DRUG)
SET DRUG=$PIECE(^PSDRUG(DRG,0),"^")
SET X=$GET(^("ND"))
SET J=+X
SET K=+$PIECE(X,"^",3)
SET X=$PIECE($GET(^PSNDF(J,5,K,2)),"^")
IF X]""
SET DRUG=X
+4 ;S QUIT=0 F J=1:1:NUM Q:QUIT S PG=1 D HEAD F K=0:0 S K=$O(^APSAPPI(PPI,P2,K)) Q:'K D WRITE1 I $Y+4>IOSL D HEAD Q:QUIT
+5 SET QUIT=0
FOR J=1:1:NUM
IF QUIT
QUIT
SET PG=1
DO HEAD
IF QUIT
QUIT
FOR K=0:0
SET K=$ORDER(^APSAPPI(PPI,P2,K))
IF 'K
QUIT
DO WRITE1
IF $Y+4>IOSL
DO HEAD
IF QUIT
QUIT
+6 IF QUIT
QUIT
+7 DO DISC
+8 KILL DRUG
+9 QUIT
WRITE1 ;
+1 ;S TXT=^APSAPPI(.5,1,K,0)
+2 SET TXT=^APSAPPI(PPI,P2,K,0)
+3 IF TXT["GENERIC NAME"
WRITE !,?8,TXT
QUIT
+4 IF TXT[": "
WRITE !!,?8,TXT
QUIT
+5 WRITE !,?8,TXT
+6 QUIT
DISC ;PRINT TRAILER COPYRIGHT AND DISCLAIMER ON MONOGRAPH
+1 SET CR=$PIECE(^APSAPPI(.5,0),U)
SET ED=$PIECE(^APSAPPI(.5,0),U,5)
SET ED1=$EXTRACT(ED,1,4)
SET ED2=$EXTRACT(ED,5,6)
+2 SET ED3=$SELECT(ED2="01":"JANUARY",ED2="02":"FEBRUARY",ED2="03":"MARCH",ED2="04":"APRIL",ED2="05":"MAY",ED2="06":"JUNE",ED2="07":"JULY",ED2="08":"AUGUST",ED2="09":"SEPTEMBER",ED2="10":"OCTOBER",ED2="11":"NOVEMBER",ED2="12":"DECEMBER",1:"")
+3 SET PPI=.5
SET P2=2
+4 WRITE !!,?12,CR
IF $Y+4>IOSL
DO HEAD
IF QUIT
QUIT
+5 WRITE !,?16,"Information Expires ",ED3_" "_ED1,!
IF $Y+4>IOSL
DO HEAD
IF QUIT
QUIT
+6 ;add line to print copyright
+7 FOR K=0:0
SET K=$ORDER(^APSAPPI(PPI,2,K))
IF 'K
QUIT
DO WRITE1
IF $Y+4>IOSL
DO HEAD
IF QUIT
QUIT
+8 ;ACKNOWLEDGMENT PRINT
SET ACK=$PIECE(^APSAPPI(.5,3,1,0)," ",1)
WRITE !!,?16,ACK
+9 ;I $Y+4>IOSL D HEAD Q:QUIT
+10 QUIT
+11 ;
+12 ;S DIR(0)="N^1:100:0",DIR("A")="How many copies? ",DIR("B")=1 D ^DIR K DIR I $D(DIRUT) Q
+13 ;S NUM=Y
+14 QUIT
PRINT ;
+1 ;I $D(PSNDFN) S DFN=PSNDFN,NAM=$P(^DPT(DFN,0),"^") D DEM^VADPT
+2 SET QUIT=0
FOR J=1:1:NUM
IF QUIT
QUIT
SET PG=1
DO HEAD
IF QUIT
QUIT
FOR K=1:1
IF '$DATA(^TMP($JOB,"W",K))
QUIT
WRITE ^(K),!
IF $Y+4>IOSL
DO HEAD
IF QUIT
QUIT
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
DO ^%ZISC
QUIT
HEAD ;
+1 IF $DATA(PSNDFN)
SET DFN=PSNDFN
SET NAM=$PIECE(^DPT(DFN,0),"^")
DO DEM^VADPT
+2 IF PG>1
IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET QUIT=1
QUIT
+3 IF $Y
WRITE @IOF
WRITE "DRUG NAME: ",DRUG,?45,"Rx Number: "_$GET(PSRX),?70,"Page ",PG
SET PG=PG+1
+4 IF $DATA(NAM)
WRITE !,"Patient: ",NAM,?35,"Doctor: "_APSDNAM,?64,$$HTE^XLFDT(+$HOROLOG),!
+5 ;W !,?2,"DOCTOR: ",?15,APSDNAM,!!
+6 QUIT
DICS ; screen out inactives DRUG entries in file 50
+1 IF $SELECT('$GET(^PSDRUG(+Y,"I")):1,DT'>^("I"):1,1:0)
+2 QUIT
