APSAPPIP.m

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