PSSMATCH.m

PSSMATCH ;BIR/RTR-Reports for Orderable Items ; 09/02/97 8:40

 ;;1.0;PHARMACY DATA MANAGEMENT;;9/30/97

PRI D CPK G:$G(PSSITEQT) CPK1 W !,"These reports are based on creating your Orderable Item file by Primary Name,",!,"then by VA Generic Name." S VAONLY=0 G DIR

VA D CPK G:$G(PSSITEQT) CPK1 W !,"There reports are based on creating your Orderable Item File by VA Generic Name." S VAONLY=1

DIR K DIR S DIR(0)="S^M:Drugs that will match;C:Drugs that can't be matched",DIR("A",1)="Enter M for Orderable Items that will auto-create,",DIR("A",2)="which includes Dispense Drugs, Additives, and Solutions that will match."

 S DIR("A",3)="Enter C for the report of Dispense Drugs that can't auto-match.",DIR("A",4)="",DIR("A")="Enter M or C" D ^DIR K DIR

 G:Y["^"!($D(DUOUT))!($D(DTOUT)) END

 S PSMATCH=$S(Y="M":1,1:0)

 W $C(7),!!,"**WARNING** THIS REPORT MAY BE VERY LONG!"

 D RMES^PSSPOIM1

QUE W ! K %ZIS,IOP,ZTSK S %ZIS("B")="",%ZIS="QM" D ^%ZIS I POP G END

 I $E(IOST)["C"!('$D(IO("Q"))) W $C(7),!?5,"This report must be QUEUED to a printer, enter Q at Device prompt!",! G QUE

 S ZTRTN="BEG^PSSMATCH",ZTDESC="Orderable Item Reports",ZTSAVE("PSMATCH")="",ZTSAVE("VAONLY")="" D ^%ZTLOAD K IO("Q")

END K ^TMP("PSSD",$J),^TMP("PSS",$J),^TMP("PSSADD",$J),^TMP("PSSOL",$J),AAA,BBB,DIR,DOSEFORM,EEE,GFLAG,GGG,LINE,LLL,PAGE,PSMATCH,PSODD,PSOIV,PSOLU,REASON,ANM,AVL,SSS,TTT,VAONLY,VARONE,VARTWO,ZFLAG,ZZZ D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q

BEG S SSITE=$O(^PS(59.7,0)),SITEADD=$S($P($G(^PS(59.7,+SSITE,31)),"^",2)'="":$P(^(31),"^",2),1:"IV") K SSITE

 G:'PSMATCH CANT

 D ^PSSSPD I VAONLY K ^TMP("PSSD",$J),^TMP("PSS",$J),^TMP("PSSADD",$J,"ZZZZ"),^TMP("PSSOL",$J,"ZZZZ") G PASS

 K ^TMP("PSSD",$J,"ZZZZ"),^TMP("PSSADD",$J,"ZZZZ"),^TMP("PSSOL",$J,"ZZZZ")

PASS D:VAONLY BEG^PSSPOIM D:'VAONLY BEG^PSSPOIC

 K LINE S $P(LINE,"-",79)="",PAGE=1,(ZFLAG,GFLAG)=0

 D ADD

 D SOL

 S PAGE=1 D HEAD

 S ZZZ="" F  S ZZZ=$O(^TMP("PSSD",$J,ZZZ)) Q:ZZZ=""  S:($Y+6)>IOSL ZFLAG=1 D:ZFLAG HEAD W:'ZFLAG !,LINE,!,ZZZ S ZFLAG=0 S GGG="" F  S GGG=$O(^TMP("PSSD",$J,ZZZ,GGG)) Q:GGG=""  D

 .S:($Y+4)>IOSL GFLAG=1 D:GFLAG HEAD W !,?2,GGG,"  ",$S(^TMP("PSSD",$J,ZZZ,GGG)'="":"("_$E($P(^(GGG),"^"),1,33)_")",1:"")

 W @IOF G END

HEAD W @IOF

 I $G(VAONLY) W !,?2,"ORDERABLE ITEMS - MATCHES BY VA GENERIC NAME ONLY             PAGE ",PAGE

 I '$G(VAONLY) W !,?2,"ORDERABLE ITEMS - MATCHES BY PRIMARY NAME THEN VA GENERIC NAME    PAGE ",PAGE,!?4,"(PRIMARY DRUG) IN PARENTHESIS"

 W !,LINE S PAGE=PAGE+1

 I ZFLAG W !!,ZZZ Q

 I GFLAG W !!,ZZZ," (cont.)"

 S GFLAG=0 Q

ADD ;

 D ADHEAD

 S AAA="" F  S AAA=$O(^TMP("PSSADD",$J,AAA)) Q:AAA=""  S VARTWO="",PSODD=$O(^TMP("PSSADD",$J,AAA,VARTWO)) S DOSEFORM=^(PSODD) D

 .D:($Y+5)>IOSL ADHEAD W !,AAA,"   ",SITEADD,!?3,PSODD,"  ",DOSEFORM,!,LINE

 W @IOF Q

ADHEAD W @IOF W !?2,"ORDERABLE ITEM (ADDITIVE)    IV FLAG",?69,"PAGE ",PAGE,!,"   DISPENSE DRUG   DOSE FORM",!,LINE S PAGE=PAGE+1

 Q

SOL ;

 S PAGE=1,(GFLAG,ZFLAG)=0 D SOLHEAD

 S FFF="" F  S FFF=$O(^TMP("PSSOL",$J,FFF)) Q:FFF=""  S ZZZ="" F  S ZZZ=$O(^TMP("PSSOL",$J,FFF,ZZZ)) Q:ZZZ=""  D

 .S:($Y+6)>IOSL ZFLAG=1 D:ZFLAG SOLHEAD W:'ZFLAG !,LINE,!,FFF,"  ",ZZZ S ZFLAG=0 S WWW="" F  S WWW=$O(^TMP("PSSOL",$J,FFF,ZZZ,WWW)) Q:WWW=""  D

 ..S:($Y+4)>IOSL GFLAG=1 D:GFLAG SOLHEAD W !?2,FFF,"   ",$P($G(^PS(52.7,+^TMP("PSSOL",$J,FFF,ZZZ,WWW),0)),"^",3)

 W @IOF Q

SOLHEAD W @IOF W !?2,"ORDERABLE ITEM (SOLUTION)   DOSE FORM",?69,"PAGE ",PAGE,!,"   SOLUTION       VOLUME",!,LINE S PAGE=PAGE+1

 I ZFLAG W !!,FFF,"  ",ZZZ Q

 I GFLAG W !!,FFF,"  ",ZZZ," (cont.)"

 S GFLAG=0 Q

CANT ;

 D ^PSSSPD I VAONLY K ^TMP("PSSD",$J),^TMP("PSS",$J)

SKIP D:VAONLY CANT^PSSPOIM D:'VAONLY CANT^PSSPOIC

 K LINE S $P(LINE,"-",79)="",PAGE=1,(ZFLAG,GFLAG)=0

 D ADDCANT

 D SOLCANT

NO S PAGE=1 D NOHEAD

 S EEE="" F  S EEE=$O(^TMP("PSSD",$J,"ZZZZ",EEE)) Q:EEE=""  S REASON=^(EEE) D:($Y+5)>IOSL NOHEAD W !,EEE,?43,REASON D:($O(^(EEE,0)))  W !,LINE

 .F TTT=0:0 S TTT=$O(^TMP("PSSD",$J,"ZZZZ",EEE,TTT)) Q:'TTT  S:($Y+5)>IOSL ZFLAG=1 D:($Y+5)>IOSL NOHEAD W !?3,^(TTT)

 W @IOF G END

NOHEAD W @IOF W !,?2,$S($G(VAONLY):"ORDERABLE ITEMS - VA GENERIC NAME ONLY, CAN'T MATCH",1:"ORDERABLE ITEMS - PRIMARY NAME THEN VA GENERIC NAME, CAN'T MATCH"),?69,"PAGE ",PAGE,!,LINE S PAGE=PAGE+1

 I ZFLAG W !,EEE,?43,REASON S ZFLAG=0

 Q

ADDCANT ;

 D HEADA

 S BBB="" F  S BBB=$O(^TMP("PSSADD",$J,"ZZZZ",BBB)) Q:BBB=""  S REASON=^(BBB),ANM=$O(^PSDRUG("B",BBB,0)) Q:'ANM  D  Q:ANM=""  D:($Y+5)>IOSL HEADA W !,ANM,?43,$G(REASON),!,LINE

 .S ANM=$O(^PS(52.6,"AC",ANM,0)),ANM=$P($G(^PS(52.6,+$G(ANM),0)),"^")

 W @IOF Q

HEADA W @IOF W !?2,"ORDERABLE ITEMS - ADDITIVES THAT CANNOT AUTO MATCH",?69,"PAGE ",PAGE,!,LINE S PAGE=PAGE+1

 Q

SOLCANT ;

 S PAGE=1 D HEADS

 S LLL="" F  S LLL=$O(^TMP("PSSOL",$J,"ZZZZ",LLL)) Q:LLL=""  S REASON=^(LLL),ANM=$O(^PSDRUG("B",LLL,0)) Q:'ANM  D  Q:ANM=""  D:($Y+6)>IOSL HEADS W !,ANM,?43,AVL,!?5,$G(REASON),!,LINE

 .S ANM=$O(^PS(52.7,"AC",ANM,0)),AVL=$P($G(^PS(52.7,+$G(ANM),0)),"^",3),ANM=$P($G(^PS(52.7,+$G(ANM),0)),"^")

 W @IOF Q

HEADS W @IOF W !?2,"ORDERABLE ITEMS - SOLUTIONS THAT CANNOT AUTO MATCH",?69,"PAGE ",PAGE,!,LINE S PAGE=PAGE+1

 Q

CPK S PSSITE=+$O(^PS(59.7,0)) I +$P($G(^PS(59.7,PSSITE,80)),"^",2)>1 W !!,"The Orderable Item auto-create has already run to completion!",! S PSSITEQT=1 K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR

 Q

CPK1 K PSSITEQT Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSSMATCH   5378     printed  Apr 23, 2025@18:47:01                                                                                                                                                                                                    Page 2

PSSMATCH  ;BIR/RTR-Reports for Orderable Items ; 09/02/97 8:40

 +1       ;;1.0;PHARMACY DATA MANAGEMENT;;9/30/97

PRI        DO CPK

           if $GET(PSSITEQT)

               GOTO CPK1

           WRITE !,"These reports are based on creating your Orderable Item file by Primary Name,",!,"then by VA Generic Name."

           SET VAONLY=0

           GOTO DIR

VA         DO CPK

           if $GET(PSSITEQT)

               GOTO CPK1

           WRITE !,"There reports are based on creating your Orderable Item File by VA Generic Name."

           SET VAONLY=1

DIR        KILL DIR

           SET DIR(0)="S^M:Drugs that will match;C:Drugs that can't be matched"

           SET DIR("A",1)="Enter M for Orderable Items that will auto-create,"

           SET DIR("A",2)="which includes Dispense Drugs, Additives, and Solutions that will match."

 +1        SET DIR("A",3)="Enter C for the report of Dispense Drugs that can't auto-match."

           SET DIR("A",4)=""

           SET DIR("A")="Enter M or C"

           DO ^DIR

           KILL DIR

 +2        if Y["^"!($DATA(DUOUT))!($DATA(DTOUT))

               GOTO END

 +3        SET PSMATCH=$SELECT(Y="M":1,1:0)

 +4        WRITE $CHAR(7),!!,"**WARNING** THIS REPORT MAY BE VERY LONG!"

 +5        DO RMES^PSSPOIM1

QUE        WRITE !

           KILL %ZIS,IOP,ZTSK

           SET %ZIS("B")=""

           SET %ZIS="QM"

           DO ^%ZIS

           IF POP

               GOTO END

 +1        IF $EXTRACT(IOST)["C"!('$DATA(IO("Q")))

               WRITE $CHAR(7),!?5,"This report must be QUEUED to a printer, enter Q at Device prompt!",!

               GOTO QUE

 +2        SET ZTRTN="BEG^PSSMATCH"

           SET ZTDESC="Orderable Item Reports"

           SET ZTSAVE("PSMATCH")=""

           SET ZTSAVE("VAONLY")=""

           DO ^%ZTLOAD

           KILL IO("Q")

END        KILL ^TMP("PSSD",$JOB),^TMP("PSS",$JOB),^TMP("PSSADD",$JOB),^TMP("PSSOL",$JOB),AAA,BBB,DIR,DOSEFORM,EEE,GFLAG,GGG,LINE,LLL,PAGE,PSMATCH,PSODD,PSOIV,PSOLU,REASON,ANM,AVL,SSS,TTT,VAONLY,VARONE,VARTWO,ZFLAG,ZZZ

           DO ^%ZISC

           if $DATA(ZTQUEUED)

               SET ZTREQ="@"

           QUIT 

BEG        SET SSITE=$ORDER(^PS(59.7,0))

           SET SITEADD=$SELECT($PIECE($GET(^PS(59.7,+SSITE,31)),"^",2)'="":$PIECE(^(31),"^",2),1:"IV")

           KILL SSITE

 +1        if 'PSMATCH

               GOTO CANT

 +2        DO ^PSSSPD

           IF VAONLY

               KILL ^TMP("PSSD",$JOB),^TMP("PSS",$JOB),^TMP("PSSADD",$JOB,"ZZZZ"),^TMP("PSSOL",$JOB,"ZZZZ")

               GOTO PASS

 +3        KILL ^TMP("PSSD",$JOB,"ZZZZ"),^TMP("PSSADD",$JOB,"ZZZZ"),^TMP("PSSOL",$JOB,"ZZZZ")

PASS       if VAONLY

               DO BEG^PSSPOIM

           if 'VAONLY

               DO BEG^PSSPOIC

 +1        KILL LINE

           SET $PIECE(LINE,"-",79)=""

           SET PAGE=1

           SET (ZFLAG,GFLAG)=0

 +2        DO ADD

 +3        DO SOL

 +4        SET PAGE=1

           DO HEAD

 +5        SET ZZZ=""

           FOR 

               SET ZZZ=$ORDER(^TMP("PSSD",$JOB,ZZZ))

               if ZZZ=""

                   QUIT 

               if ($Y+6)>IOSL

                   SET ZFLAG=1

               if ZFLAG

                   DO HEAD

               if 'ZFLAG

                   WRITE !,LINE,!,ZZZ

               SET ZFLAG=0

               SET GGG=""

               FOR 

                   SET GGG=$ORDER(^TMP("PSSD",$JOB,ZZZ,GGG))

                   if GGG=""

                       QUIT 

                   Begin DoDot:1

 +6                    if ($Y+4)>IOSL

                           SET GFLAG=1

                       if GFLAG

                           DO HEAD

                       WRITE !,?2,GGG,"  ",$SELECT(^TMP("PSSD",$JOB,ZZZ,GGG)'="":"("_$EXTRACT($PIECE(^(GGG),"^"),1,33)_")",1:"")

                   End DoDot:1

 +7        WRITE @IOF

           GOTO END

HEAD       WRITE @IOF

 +1        IF $GET(VAONLY)

               WRITE !,?2,"ORDERABLE ITEMS - MATCHES BY VA GENERIC NAME ONLY             PAGE ",PAGE

 +2        IF '$GET(VAONLY)

               WRITE !,?2,"ORDERABLE ITEMS - MATCHES BY PRIMARY NAME THEN VA GENERIC NAME    PAGE ",PAGE,!?4,"(PRIMARY DRUG) IN PARENTHESIS"

 +3        WRITE !,LINE

           SET PAGE=PAGE+1

 +4        IF ZFLAG

               WRITE !!,ZZZ

               QUIT 

 +5        IF GFLAG

               WRITE !!,ZZZ," (cont.)"

 +6        SET GFLAG=0

           QUIT 

ADD       ;

 +1        DO ADHEAD

 +2        SET AAA=""

           FOR 

               SET AAA=$ORDER(^TMP("PSSADD",$JOB,AAA))

               if AAA=""

                   QUIT 

               SET VARTWO=""

               SET PSODD=$ORDER(^TMP("PSSADD",$JOB,AAA,VARTWO))

               SET DOSEFORM=^(PSODD)

               Begin DoDot:1

 +3                if ($Y+5)>IOSL

                       DO ADHEAD

                   WRITE !,AAA,"   ",SITEADD,!?3,PSODD,"  ",DOSEFORM,!,LINE

               End DoDot:1

 +4        WRITE @IOF

           QUIT 

ADHEAD     WRITE @IOF

           WRITE !?2,"ORDERABLE ITEM (ADDITIVE)    IV FLAG",?69,"PAGE ",PAGE,!,"   DISPENSE DRUG   DOSE FORM",!,LINE

           SET PAGE=PAGE+1

 +1        QUIT 

SOL       ;

 +1        SET PAGE=1

           SET (GFLAG,ZFLAG)=0

           DO SOLHEAD

 +2        SET FFF=""

           FOR 

               SET FFF=$ORDER(^TMP("PSSOL",$JOB,FFF))

               if FFF=""

                   QUIT 

               SET ZZZ=""

               FOR 

                   SET ZZZ=$ORDER(^TMP("PSSOL",$JOB,FFF,ZZZ))

                   if ZZZ=""

                       QUIT 

                   Begin DoDot:1

 +3                    if ($Y+6)>IOSL

                           SET ZFLAG=1

                       if ZFLAG

                           DO SOLHEAD

                       if 'ZFLAG

                           WRITE !,LINE,!,FFF,"  ",ZZZ

                       SET ZFLAG=0

                       SET WWW=""

                       FOR 

                           SET WWW=$ORDER(^TMP("PSSOL",$JOB,FFF,ZZZ,WWW))

                           if WWW=""

                               QUIT 

                           Begin DoDot:2

 +4                            if ($Y+4)>IOSL

                                   SET GFLAG=1

                               if GFLAG

                                   DO SOLHEAD

                               WRITE !?2,FFF,"   ",$PIECE($GET(^PS(52.7,+^TMP("PSSOL",$JOB,FFF,ZZZ,WWW),0)),"^",3)

                           End DoDot:2

                   End DoDot:1

 +5        WRITE @IOF

           QUIT 

SOLHEAD    WRITE @IOF

           WRITE !?2,"ORDERABLE ITEM (SOLUTION)   DOSE FORM",?69,"PAGE ",PAGE,!,"   SOLUTION       VOLUME",!,LINE

           SET PAGE=PAGE+1

 +1        IF ZFLAG

               WRITE !!,FFF,"  ",ZZZ

               QUIT 

 +2        IF GFLAG

               WRITE !!,FFF,"  ",ZZZ," (cont.)"

 +3        SET GFLAG=0

           QUIT 

CANT      ;

 +1        DO ^PSSSPD

           IF VAONLY

               KILL ^TMP("PSSD",$JOB),^TMP("PSS",$JOB)

SKIP       if VAONLY

               DO CANT^PSSPOIM

           if 'VAONLY

               DO CANT^PSSPOIC

 +1        KILL LINE

           SET $PIECE(LINE,"-",79)=""

           SET PAGE=1

           SET (ZFLAG,GFLAG)=0

 +2        DO ADDCANT

 +3        DO SOLCANT

NO         SET PAGE=1

           DO NOHEAD

 +1        SET EEE=""

           FOR 

               SET EEE=$ORDER(^TMP("PSSD",$JOB,"ZZZZ",EEE))

               if EEE=""

                   QUIT 

               SET REASON=^(EEE)

               if ($Y+5)>IOSL

                   DO NOHEAD

               WRITE !,EEE,?43,REASON

               if ($ORDER(^(EEE,0)))

                   Begin DoDot:1

 +2                    FOR TTT=0:0

                           SET TTT=$ORDER(^TMP("PSSD",$JOB,"ZZZZ",EEE,TTT))

                           if 'TTT

                               QUIT 

                           if ($Y+5)>IOSL

                               SET ZFLAG=1

                           if ($Y+5)>IOSL

                               DO NOHEAD

                           WRITE !?3,^(TTT)

                   End DoDot:1

               WRITE !,LINE

 +3        WRITE @IOF

           GOTO END

NOHEAD     WRITE @IOF

           WRITE !,?2,$SELECT($GET(VAONLY):"ORDERABLE ITEMS - VA GENERIC NAME ONLY, CAN'T MATCH",1:"ORDERABLE ITEMS - PRIMARY NAME THEN VA GENERIC NAME, CAN'T MATCH"),?69,"PAGE ",PAGE,!,LINE

           SET PAGE=PAGE+1

 +1        IF ZFLAG

               WRITE !,EEE,?43,REASON

               SET ZFLAG=0

 +2        QUIT 

ADDCANT   ;

 +1        DO HEADA

 +2        SET BBB=""

           FOR 

               SET BBB=$ORDER(^TMP("PSSADD",$JOB,"ZZZZ",BBB))

               if BBB=""

                   QUIT 

               SET REASON=^(BBB)

               SET ANM=$ORDER(^PSDRUG("B",BBB,0))

               if 'ANM

                   QUIT 

               Begin DoDot:1

 +3                SET ANM=$ORDER(^PS(52.6,"AC",ANM,0))

                   SET ANM=$PIECE($GET(^PS(52.6,+$GET(ANM),0)),"^")

               End DoDot:1

               if ANM=""

                   QUIT 

               if ($Y+5)>IOSL

                   DO HEADA

               WRITE !,ANM,?43,$GET(REASON),!,LINE

 +4        WRITE @IOF

           QUIT 

HEADA      WRITE @IOF

           WRITE !?2,"ORDERABLE ITEMS - ADDITIVES THAT CANNOT AUTO MATCH",?69,"PAGE ",PAGE,!,LINE

           SET PAGE=PAGE+1

 +1        QUIT 

SOLCANT   ;

 +1        SET PAGE=1

           DO HEADS

 +2        SET LLL=""

           FOR 

               SET LLL=$ORDER(^TMP("PSSOL",$JOB,"ZZZZ",LLL))

               if LLL=""

                   QUIT 

               SET REASON=^(LLL)

               SET ANM=$ORDER(^PSDRUG("B",LLL,0))

               if 'ANM

                   QUIT 

               Begin DoDot:1

 +3                SET ANM=$ORDER(^PS(52.7,"AC",ANM,0))

                   SET AVL=$PIECE($GET(^PS(52.7,+$GET(ANM),0)),"^",3)

                   SET ANM=$PIECE($GET(^PS(52.7,+$GET(ANM),0)),"^")

               End DoDot:1

               if ANM=""

                   QUIT 

               if ($Y+6)>IOSL

                   DO HEADS

               WRITE !,ANM,?43,AVL,!?5,$GET(REASON),!,LINE

 +4        WRITE @IOF

           QUIT 

HEADS      WRITE @IOF

           WRITE !?2,"ORDERABLE ITEMS - SOLUTIONS THAT CANNOT AUTO MATCH",?69,"PAGE ",PAGE,!,LINE

           SET PAGE=PAGE+1

 +1        QUIT 

CPK        SET PSSITE=+$ORDER(^PS(59.7,0))

           IF +$PIECE($GET(^PS(59.7,PSSITE,80)),"^",2)>1

               WRITE !!,"The Orderable Item auto-create has already run to completion!",!

               SET PSSITEQT=1

               KILL DIR

               SET DIR(0)="E"

               SET DIR("A")="Press RETURN to continue"

               DO ^DIR

               KILL DIR

 +1        QUIT 

CPK1       KILL PSSITEQT

           QUIT