- 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
