APSAPPIP ;IHS/ITSC/POC/ENM - PRINT A MEDICATION INSTRUCTION SHEET [ 08/27/2003 8:53 AM ]
;;6.1;IHS PHARMACY MODIFICATIONS;**4**;01/10/2002
;REWRITE OF APSAPPIP WITH ^DIWP
;TO VARY PAGESETUP IHS/OKCAO/POC 1/16/2002
;TAKES ADVANTAGE OF PRINTING PMI USING MARGINS IHS/OKCAO/POC 11/11/2002
EP1 ;FROM APSEPPID
D INIT
D CONT
Q
EP2 ;EP FROM APSAPPIM
D END,INIT
D CONT
Q
;
PICK ;EP SELECT A DRUG FROM FILE 50
D END,INIT
I $D(PSNDRUG) Q
I '$D(^APSAPPI) W !,"PATIENT MEDICATION INSTRUCTION SHEETS' DATA HAS NOT BEEN INSTALLED",!! H 3 Q
S DIC=50,DIC(0)="AEQMZ",DIC("S")="D DICS^APSAPPIP" 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 S PPI=.5,P2=1 ;GET NDC AND REMOVE DASHES
I XNDC="" S PPI=.5,P2=1
;
CONT ;
D SH
D DISC
D HDR
D WRITE
I '$G(QUIT),$E(IOST,1,2)="C-" K DIR S DIR(0)="E" D ^DIR ;FOR THE VERY END OF PRI NT IF TO SCREEN
D END1
Q
;
SH ;PRINT OUT MAIN BODY
N IEN S IEN=0
F S IEN=$O(^APSAPPI(PPI,1,IEN)) Q:'+IEN!QUIT D PRINTIT(^(IEN,0))
Q
;
PRINTIT(X) ;PRINT THE LINE
Q:QUIT
F Q:$E(X,$L(X))'=" " S X=$E(X,1,$L(X)-1) ;GET RID OF SPACE AT END OF LINE
S X=X_" " ;ADD A SPACE BACK AT END OF LINE
N WORD,STOP S STOP=0
F WORD="COMMON USES","HOW TO USE THIS MEDICINE","CAUTIONS","ALCOHOL WARNING","WOMEN","POSSIBLE SIDE EFFECTS","BEFORE USING THIS MEDICINE","OVERDOSE INFORMATION","ADDITIONAL INFORMATION" I X[WORD_":" D S STOP=1 Q
.N FIRST,SECOND
.S FIRST=$P(X,WORD_":",1)
.S SECOND=$P(X,WORD_":",2,99)
.I FIRST]"" S X=FIRST D ^DIWP
.D LASTLINE
.S X=WORD_":" D ^DIWP,LASTLINE
.S X=SECOND D ^DIWP
.Q
D:'STOP ^DIWP
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
;
END1 ;
K NAM
END ;KILL THE VARIABLES
K DRUG,QUIT,DIC,RN,P2,XNDC,NDC,DIWL,DIWR,DIWF
K PG,NUM,APSAIOSL
K ^UTILITY($J,"W")
Q
;
INIT ;INIT SOME VARIABLES
S PG=1,QUIT=0,NUM=1
S DIWL=5,DIWR=IOM-5
I $E(IOST,1,2)="C-" S APSAIOSL=IOSL-2
E S APSAIOSL=IOSL ;DIWF="B4" ;BOTTOM OF PAGE
I $G(PSNTRADE)'="" S DRUG=PSNTRADE
N X,J,K
I '$D(DRUG) S DRUG=$P(^PSDRUG(DRG,0),U),X=$G(^("ND")),J=+X,K=+$P(X,U,3),X=$P($G(^PSNDF(J,5,K,2)),U) I X]"" S DRUG=X
D:$D(PSNDFN)
.S DFN=PSNDFN,NAM=$P(^DPT(DFN,0),U) D DEM^VADPT
Q
;
DICS ;SCREEN
I $S('$G(^PSDRUG(+Y,"I")):1,DT'>^("I"):1,1:0)
Q
;
LASTLINE ;PA THE LAST LINE IN UTILITY TO MAXIMUM
N LASTLINE,LEN,SPACE
S LASTLINE=$G(^UTILITY($J,"W",DIWL))
Q:'+LASTLINE
Q:'$D(^UTILITY($J,"W",DIWL,LASTLINE,0))!($G(^(0))="") ;DONT PAD A LINE THAT IS NULL
S LEN=DIWR-DIWL-$L($G(^UTILITY($J,"W",DIWL,LASTLINE,0)))
Q:LEN<1
S $P(SPACE," ",LEN)=" "
S ^(0)=^UTILITY($J,"W",DIWL,LASTLINE,0)_SPACE
Q
;
HDR ;HEADER INFO
S (CNT,IEN)=0
F S IEN=$O(^UTILITY($J,"W",DIWL,IEN)) Q:'+IEN D
.I '(CNT#APSAIOSL) D HDR1,HDR2
.S CNT=CNT+1
.S ^UTILITY($J,"X",DIWL,CNT,0)=^UTILITY($J,"W",DIWL,IEN,0)
S ^UTILITY($J,"X",DIWL)=CNT
K ^UTILITY($J,"W")
M ^("W")=^UTILITY($J,"X")
K ^UTILITY($J,"X")
Q
;
HDR1 D
.N SPACE
.S $P(SPACE," ",43)=" ",X="DRUG NAME: "_DRUG_SPACE,X=$E(X,1,43)
.K SPACE S $P(SPACE," ",56)=" ",X=X_"RX#: "_$G(PSRX)_SPACE,X=$E(X,1,56)
.K SPACE S $P(SPACE," ",DIWR)=" ",X=X_"PAGE "_PG_SPACE,X=$E(X,1,DIWR)
.S CNT=CNT+1
.S ^UTILITY($J,"X",DIWL,CNT,0)=X
.S PG=PG+1
.Q
Q
;
HDR2 D:$D(PSNDFN)
.N NAM
.S DFN=PSNDFN,NAM=$P(^DPT(DFN,0),U) D DEM^VADPT
.N SPACE
.S $P(SPACE," ",30)=" ",X="PATIENT: "_NAM_SPACE,X=$E(X,1,30)
.K SPACE S $P(SPACE," ",53)=" ",X=X_"PROVIDER: "_APSDNAM_SPACE,X=$E(X,1,53),X=X_$$HTE^XLFDT(+$H)
.K SPACE S $P(SPACE," ",DIWR)=" ",X=X_SPACE,X=$E(X,1,DIWR)
.S CNT=CNT+1
.S ^UTILITY($J,"X",DIWL,CNT,0)=X
.Q
Q
;
DISC ;
;PRINT TRAILER COPYRIGHT AND DISCLAIMER ON MONOGRAPH
D LASTLINE
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 X=CR D PRINTIT(X)
S X="Expires "_ED3_" "_ED1_"." D PRINTIT(X)
N IEN S IEN=0
F S IEN=$O(^APSAPPI(.5,2,IEN)) Q:'+IEN!QUIT D
.S X=^APSAPPI(.5,2,IEN,0)
.D PRINTIT(X)
S X=$P(^APSAPPI(.5,3,1,0)," ",1) D PRINTIT(X)
Q
;
WRITE ;MY DIWW FOR ^DIWW
U IO
N UTLIEN
W:$Y'=0 @IOF
S UTLIEN=0 F S UTLIEN=$O(^UTILITY($J,"W",DIWL,UTLIEN)) Q:'+UTLIEN!QUIT D
.W ?DIWL,^UTILITY($J,"W",DIWL,UTLIEN,0),!
.D:'(UTLIEN#APSAIOSL)
..I $E(IOST,1,2)="C-" K DIR S DIR(0)="E" D ^DIR K DIR S:'Y QUIT=1
..W @IOF
Q
APSAPPIP ;IHS/ITSC/POC/ENM - PRINT A MEDICATION INSTRUCTION SHEET [ 08/27/2003 8:53 AM ]
+1 ;;6.1;IHS PHARMACY MODIFICATIONS;**4**;01/10/2002
+2 ;REWRITE OF APSAPPIP WITH ^DIWP
+3 ;TO VARY PAGESETUP IHS/OKCAO/POC 1/16/2002
+4 ;TAKES ADVANTAGE OF PRINTING PMI USING MARGINS IHS/OKCAO/POC 11/11/2002
EP1 ;FROM APSEPPID
+1 DO INIT
+2 DO CONT
+3 QUIT
EP2 ;EP FROM APSAPPIM
+1 DO END
DO INIT
+2 DO CONT
+3 QUIT
+4 ;
PICK ;EP SELECT A DRUG FROM FILE 50
+1 DO END
DO INIT
+2 IF $DATA(PSNDRUG)
QUIT
+3 IF '$DATA(^APSAPPI)
WRITE !,"PATIENT MEDICATION INSTRUCTION SHEETS' DATA HAS NOT BEEN INSTALLED",!!
HANG 3
QUIT
+4 SET DIC=50
SET DIC(0)="AEQMZ"
SET DIC("S")="D DICS^APSAPPIP"
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
SET PPI=.5
SET P2=1
+6 IF XNDC=""
SET PPI=.5
SET P2=1
+7 ;
CONT ;
+1 DO SH
+2 DO DISC
+3 DO HDR
+4 DO WRITE
+5 ;FOR THE VERY END OF PRI NT IF TO SCREEN
IF '$GET(QUIT)
IF $EXTRACT(IOST,1,2)="C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
+6 DO END1
+7 QUIT
+8 ;
SH ;PRINT OUT MAIN BODY
+1 NEW IEN
SET IEN=0
+2 FOR
SET IEN=$ORDER(^APSAPPI(PPI,1,IEN))
IF '+IEN!QUIT
QUIT
DO PRINTIT(^(IEN,0))
+3 QUIT
+4 ;
PRINTIT(X) ;PRINT THE LINE
+1 IF QUIT
QUIT
+2 ;GET RID OF SPACE AT END OF LINE
FOR
IF $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+3 ;ADD A SPACE BACK AT END OF LINE
SET X=X_" "
+4 NEW WORD,STOP
SET STOP=0
+5 FOR WORD="COMMON USES","HOW TO USE THIS MEDICINE","CAUTIONS","ALCOHOL WARNING","WOMEN","POSSIBLE SIDE EFFECTS","BEFORE USING THIS MEDICINE","OVERDOSE INFORMATION","ADDITIONAL INFORMATION"
IF X[WORD_":"
Begin DoDot:1
+6 NEW FIRST,SECOND
+7 SET FIRST=$PIECE(X,WORD_":",1)
+8 SET SECOND=$PIECE(X,WORD_":",2,99)
+9 IF FIRST]""
SET X=FIRST
DO ^DIWP
+10 DO LASTLINE
+11 SET X=WORD_":"
DO ^DIWP
DO LASTLINE
+12 SET X=SECOND
DO ^DIWP
+13 QUIT
End DoDot:1
SET STOP=1
QUIT
+14 IF 'STOP
DO ^DIWP
+15 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
+6 ;
END1 ;
+1 KILL NAM
END ;KILL THE VARIABLES
+1 KILL DRUG,QUIT,DIC,RN,P2,XNDC,NDC,DIWL,DIWR,DIWF
+2 KILL PG,NUM,APSAIOSL
+3 KILL ^UTILITY($JOB,"W")
+4 QUIT
+5 ;
INIT ;INIT SOME VARIABLES
+1 SET PG=1
SET QUIT=0
SET NUM=1
+2 SET DIWL=5
SET DIWR=IOM-5
+3 IF $EXTRACT(IOST,1,2)="C-"
SET APSAIOSL=IOSL-2
+4 ;DIWF="B4" ;BOTTOM OF PAGE
IF '$TEST
SET APSAIOSL=IOSL
+5 IF $GET(PSNTRADE)'=""
SET DRUG=PSNTRADE
+6 NEW X,J,K
+7 IF '$DATA(DRUG)
SET DRUG=$PIECE(^PSDRUG(DRG,0),U)
SET X=$GET(^("ND"))
SET J=+X
SET K=+$PIECE(X,U,3)
SET X=$PIECE($GET(^PSNDF(J,5,K,2)),U)
IF X]""
SET DRUG=X
+8 IF $DATA(PSNDFN)
Begin DoDot:1
+9 SET DFN=PSNDFN
SET NAM=$PIECE(^DPT(DFN,0),U)
DO DEM^VADPT
End DoDot:1
+10 QUIT
+11 ;
DICS ;SCREEN
+1 IF $SELECT('$GET(^PSDRUG(+Y,"I")):1,DT'>^("I"):1,1:0)
+2 QUIT
+3 ;
LASTLINE ;PA THE LAST LINE IN UTILITY TO MAXIMUM
+1 NEW LASTLINE,LEN,SPACE
+2 SET LASTLINE=$GET(^UTILITY($JOB,"W",DIWL))
+3 IF '+LASTLINE
QUIT
+4 ;DONT PAD A LINE THAT IS NULL
IF '$DATA(^UTILITY($JOB,"W",DIWL,LASTLINE,0))!($GET(^(0))="")
QUIT
+5 SET LEN=DIWR-DIWL-$LENGTH($GET(^UTILITY($JOB,"W",DIWL,LASTLINE,0)))
+6 IF LEN<1
QUIT
+7 SET $PIECE(SPACE," ",LEN)=" "
+8 SET ^(0)=^UTILITY($JOB,"W",DIWL,LASTLINE,0)_SPACE
+9 QUIT
+10 ;
HDR ;HEADER INFO
+1 SET (CNT,IEN)=0
+2 FOR
SET IEN=$ORDER(^UTILITY($JOB,"W",DIWL,IEN))
IF '+IEN
QUIT
Begin DoDot:1
+3 IF '(CNT#APSAIOSL)
DO HDR1
DO HDR2
+4 SET CNT=CNT+1
+5 SET ^UTILITY($JOB,"X",DIWL,CNT,0)=^UTILITY($JOB,"W",DIWL,IEN,0)
End DoDot:1
+6 SET ^UTILITY($JOB,"X",DIWL)=CNT
+7 KILL ^UTILITY($JOB,"W")
+8 MERGE ^("W")=^UTILITY($JOB,"X")
+9 KILL ^UTILITY($JOB,"X")
+10 QUIT
+11 ;
HDR1 Begin DoDot:1
+1 NEW SPACE
+2 SET $PIECE(SPACE," ",43)=" "
SET X="DRUG NAME: "_DRUG_SPACE
SET X=$EXTRACT(X,1,43)
+3 KILL SPACE
SET $PIECE(SPACE," ",56)=" "
SET X=X_"RX#: "_$GET(PSRX)_SPACE
SET X=$EXTRACT(X,1,56)
+4 KILL SPACE
SET $PIECE(SPACE," ",DIWR)=" "
SET X=X_"PAGE "_PG_SPACE
SET X=$EXTRACT(X,1,DIWR)
+5 SET CNT=CNT+1
+6 SET ^UTILITY($JOB,"X",DIWL,CNT,0)=X
+7 SET PG=PG+1
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
HDR2 IF $DATA(PSNDFN)
Begin DoDot:1
+1 NEW NAM
+2 SET DFN=PSNDFN
SET NAM=$PIECE(^DPT(DFN,0),U)
DO DEM^VADPT
+3 NEW SPACE
+4 SET $PIECE(SPACE," ",30)=" "
SET X="PATIENT: "_NAM_SPACE
SET X=$EXTRACT(X,1,30)
+5 KILL SPACE
SET $PIECE(SPACE," ",53)=" "
SET X=X_"PROVIDER: "_APSDNAM_SPACE
SET X=$EXTRACT(X,1,53)
SET X=X_$$HTE^XLFDT(+$HOROLOG)
+6 KILL SPACE
SET $PIECE(SPACE," ",DIWR)=" "
SET X=X_SPACE
SET X=$EXTRACT(X,1,DIWR)
+7 SET CNT=CNT+1
+8 SET ^UTILITY($JOB,"X",DIWL,CNT,0)=X
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
DISC ;
+1 ;PRINT TRAILER COPYRIGHT AND DISCLAIMER ON MONOGRAPH
+2 DO LASTLINE
+3 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)
+4 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:"")
+5 SET X=CR
DO PRINTIT(X)
+6 SET X="Expires "_ED3_" "_ED1_"."
DO PRINTIT(X)
+7 NEW IEN
SET IEN=0
+8 FOR
SET IEN=$ORDER(^APSAPPI(.5,2,IEN))
IF '+IEN!QUIT
QUIT
Begin DoDot:1
+9 SET X=^APSAPPI(.5,2,IEN,0)
+10 DO PRINTIT(X)
End DoDot:1
+11 SET X=$PIECE(^APSAPPI(.5,3,1,0)," ",1)
DO PRINTIT(X)
+12 QUIT
+13 ;
WRITE ;MY DIWW FOR ^DIWW
+1 USE IO
+2 NEW UTLIEN
+3 IF $Y'=0
WRITE @IOF
+4 SET UTLIEN=0
FOR
SET UTLIEN=$ORDER(^UTILITY($JOB,"W",DIWL,UTLIEN))
IF '+UTLIEN!QUIT
QUIT
Begin DoDot:1
+5 WRITE ?DIWL,^UTILITY($JOB,"W",DIWL,UTLIEN,0),!
+6 IF '(UTLIEN#APSAIOSL)
Begin DoDot:2
+7 IF $EXTRACT(IOST,1,2)="C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET QUIT=1
+8 WRITE @IOF
End DoDot:2
End DoDot:1
+9 QUIT
