ACMSRT.m

ACMSRT ; IHS/TUCSON/TMJ - SORT CONTROLLER FOR REPORTS ; [ 02/10/2009  9:50 AM ]

 ;;2.0;ACM CASE MANAGEMENT SYSTEM;**4,6,8**;JAN 10, 1996

EN ;PEP - ENTRY POINT FOR SORT VARIABLES

 K ACMQUIT

 D ^ACMSRT2

 Q:$D(ACMQUIT)

EN1 D HEAD,CHOICE

EXIT D EXIT^ACMSRT1

 Q

HEAD D HEAD^ACMMENU

 S ACMX="REPORT SORTING UTILITY"

 W !!?80-$L(ACMX)\2,ACMX,!!?10,"The ",@ACMRVON,ACMRPT,@ACMRVOFF," report can be sorted by one or more",!?10,"of the following attributes.  '<==' indicates a mandatory selection.",!

 K ACMX,ACMFORC

 Q

CHOICE D M2

C1 I $D(ACMXZ) W !!?10,"Sorting by: ",ACMXZ

 S DIR(0)="NOA^1:"_$S(ACMYI>1:ACMYI,1:1),DIR("A")="          Your choice: ",DIR("?")="Type "_$S(ACMYI>1:"a number from 1",1:"number 1: ")_$S(ACMYI>1:"-"_ACMYI_":",1:"")

 W !

 D ^DIR K DIR

 I $E(X)=U!(X="") S ACMQUIT="" Q

 I ACMUB(Y)="" W !!,"Already selected as a sort criterion." G C1

 S ACMZZ=Y

 G:'ACMZZ CHOICE

OK S:'$D(ACMXZ) ACMXZ=""

 S ACMYZ=ACMU(ACMZZ),(X,ACMSNO)=+ACMYZ,ACMSNA=$P(ACMYZ,U,2),ACMCSTG=ACMCSTG_ACMZZ_U,ACMXZ=ACMXZ_$S(ACMXZ'="":", then ",1:"")_ACMSNA

 K ACMYZ

 S ACMUB(ACMZZ)=""

 W "   ",ACMSNA

OK1 I BY'="" S BY=BY_","

 S ACMNAV=^ACM(48.5,X,0)

 I $D(ACMDM),$P(^ACM(48.5,X,0),U,5)["41," F ACMJ=42,43,44,45,46,47,48,49,51,53,57 I ACMFILE=ACMJ,(($P(^ACM(48.5,X,0),U,2)="P"!($P(^(0),U,2)="D")!($P(^(0),U,2)="A")))!(ACMSNA["STATUS") S BY=BY_"REGISTER:," Q  ;IHS/CIM/THL PATCH 4

 I ACMSNA["APPOINT",ACMFILE=41 S BY=BY_"CMS APPOINTMENT:,"

 I ACMSNA["REGISTER-" S BY=BY_"REGISTER,"

 K ACMJ

 S BY=BY_^ACM(48.5,X,3)

 I BY["EDITED NOT PRINTED" S BY="[ACM EDITED NOT PRINTED]",DIC=ACMDIC K FR,TO D PRT1 S ACMQUIT="" Q

 D @("S"_$P(ACMNAV,U,2)_"^ACMSRT1")

 K ACMNAV

 I $D(ACMQUIT) Q

 I $D(ACMFORC) K ACMFORC D PRINT Q

 I BY["[" S BY="["_$P(BY,"[",2) S BY=$P(BY,"]")_"]" D PRINT Q

 I ACMYI<2 D PRINT Q

 W !!,"Within ",ACMSNA,", want to sort by another attribute"

 S %=2 D YN^DICN

 I %Y=U S ACMQUIT="" Q

 I "Nn"[$E(%Y) D CHECK G:$D(ACMFORC) OK D PRINT Q

 W !!!

 S ACMN=ACMN+1

 G EN1

M2 K ACMU

 S ACMYII=ACMYI\2+(ACMYI#2)

 S (ACMJ,ACMZ)=0

 F ACMJ=1:1:ACMYII D

 .I ACMUB(ACMJ)'="" D

 ..S (ACMU(ACMJ),ACMSRT)=ACMUB(ACMJ),X=$P(ACMSRT,U,2),Y=$P(ACMSRT,U),ACMYZ=$P(ACMSRT,U,3)

 ..W !?8,$J(ACMJ,3),") ",X I ACMYZ W " <==" S ACMMAND=ACMJ,ACMMANN=X,ACMMAN=Y_U_X

 .E  W !?8,$J(ACMJ,3),") "

 .I $D(ACMUB(ACMJ+ACMYII)) D

 ..S ACMJ1=ACMJ+ACMYII

 ..S (ACMU(ACMJ1),ACMSRT)=ACMUB(ACMJ1),X=$P(ACMSRT,U,2),Y=$P(ACMSRT,U),ACMYZ=$P(ACMSRT,U,3)

 ..W ?45,$J(ACMJ1,3),") ",X I ACMYZ W " <==" S ACMMAND=ACMJ1,ACMMANN=X,ACMMAN=Y_U_X

 .E  I $D(ACMJ1) W:$D(ACMUB(ACMJ1+1)) ?45,$J(ACMJ1,3),") "

 K ACMSRT,ACMZ,ACMYZ

 Q

PS I ACMRPT["RECALL LETTERS" S ACMX="P" Q

 D PS^ACMSRT1

 Q

PRINT I $D(ACMPP),$D(ACMDM),((ACMFILE'=41)&(ACMFILE'=48)) D PS Q:$D(ACMQUIT)

PRNT S DIC=ACMDIC

 I $D(ACMDM),DIC["41",BY'["STATUS" S BY="@STATUS,"_BY,TO="ACTIVE,"_TO,FR="ACTIVE,"_FR

 I $D(ACMDM),DIC["41" S BY="@NAME OF REGISTER,"_BY,TO=ACMRGNA_","_TO,FR=ACMRGNA_","_FR G PRT1

 I $D(ACMDM),DIC'["41" F ACMJ=42,43,44,45,46,47,48,49,51,53,57 I ACMFILE=ACMJ S:BY'["STATUS" BY="REGISTER:,@STATUS,"_BY,TO="ACTIVE,"_TO,FR="ACTIVE,"_FR Q  ;IHS/CIM/THL PATCH 4

 I $D(ACMDM),DIC'["41" F ACMJ=42,43,44,45,46,47,48,49,51,53,57 I ACMFILE=ACMJ S BY="@NAME OF REGISTER,"_BY,TO=ACMRGNA_","_TO,FR=ACMRGNA_","_FR Q

 K ACMJ

PRT1 I ACMDIC'["." S ACMSDIC=$P(ACMDIC,",")_")" D:$E(ACMENTRY,1,4)'="APPL" ^ACMSTMP

 D ZIS

 I $D(ACMQUIT) K ACMQUIT Q

 S DIOEND="W:IOST[""C-"" !!,""End of report.  Strike <CR> to continue."" R:IOST[""C-"" ACMX:300 W:$D(IOF) @IOF"

 W ! D WAIT^DICD W !

 S IOP=ION

DIP S DIC=ACMDIC,DC=0

 D EN1^DIP

 D ^%ZISC

 Q

ZIS I $E(ACMENTRY,1,3)="MPS" S DIR(0)="YO",DIR("A")="Include PCC HEALTH SUMMARY",DIR("B")="NO" W ! D ^DIR K DIR I Y=1 S ACMMHS="" D SELTYP^ACMPPDTX

 I $E(ACMENTRY,1,4)="APPL" S DIR(0)="YO",DIR("A")="Do you want to VIEW the Standard Letter before printing",DIR("B")="NO" W ! D ^DIR K DIR I Y=1 W ! S ACMBY=BY,ACMFR=FR,ACMTO=TO,ACMFLDS=FLDS D ^ACMLTR2 G:ACMLTREX=1 ACMLTREX D

 .S DIC=ACMDIC,BY=ACMBY,FLDS=ACMFLDS,L=0,FR=ACMFR,TO=ACMTO K ACMBY,ACMFLDS,ACMFR,ACMTO

 .Q

 K IOP

 S %ZIS="PMNQ"

 W !

 K IOP

 D ^%ZIS

 G:POP DONE

 S:ION["HOST" %ZIS("IOPAR")=IOPAR

 I IO=IO(0),$D(IO("Q")) W !,"Cannot Queue to Screen or Slave Printer!",! K IO("Q") G ZIS

 ;I IO'=IO(0),'$D(IO("Q")) W !,"I will QUEUE this report to run for you now." S IO("Q")=1

 I $D(IO("Q")) D TSK S ACMQUIT=""

 Q

TSK S ZTRTN="DIP^ACMSRT",DIC=ACMDIC,IOP=ION

 S ZTSAVE("*")=""

 S ZTDESC="CMS REPORT",ZTIO=IO

 D ^%ZTLOAD

 W !,"REQUEST QUEUED!"

 K IO("Q"),ZTSK

DONE I '$D(ZTQUEUED) D ^%ZISC

 S ACMQUIT=""

 Q

CHECK I ACMCSTG[(U_ACMMAND_U) Q

 S ACMZZ=ACMMAND,ACMFORC="",ACMN=ACMN+1

 W !!,*7,"You must also sort by"

 Q

ENTRY ;EP;VARIABLE TO CONTROL SORT

 S ACMENTRY=$T(@ACMENTRY^ACMCTRL1) G EN

 ;

ACMLTREX ;Exit if User doesn't want to print letter

 K ACMLTREX G DONE

 ;

BACKEXIT ;Tmp qued in bckgrnd

 K ACMBACK G DONE

 ;

AMPM(FMDT)         ;EP; return fileman date in AM/PM

 ;IHS/CMI/TMJ PATCH #6

 I $P(FMDT,".",2)="" Q $$FMTE^XLFDT(FMDT)

 I $L($P(FMDT,"."))'=7 Q ""

 S FMTE=$$FMTE^XLFDT(FMDT)

 S FMTED=$P(FMTE,"@")

 S FMTEMC=$P(FMTE,"@",2)

 S FMTEH=$E(FMTEMC,1,2)

 S FMTEM=$E(FMTEMC,4,5)

 I FMTEH=12 Q FMTED_"@"_FMTEH_":"_FMTEM_" PM"

 I FMTEH="00" Q FMTED_"@12:"_FMTEM_" AM"

 I FMTEH>12 Q FMTED_"@"_(FMTEH-12)_":"_FMTEM_" PM"

 Q FMTED_"@"_FMTEH_":"_FMTEM_" AM"

 Q

ACMSRT    ; IHS/TUCSON/TMJ - SORT CONTROLLER FOR REPORTS ; [ 02/10/2009  9:50 AM ]

 +1       ;;2.0;ACM CASE MANAGEMENT SYSTEM;**4,6,8**;JAN 10, 1996

EN        ;PEP - ENTRY POINT FOR SORT VARIABLES

 +1        KILL ACMQUIT

 +2        DO ^ACMSRT2

 +3        IF $DATA(ACMQUIT)

               QUIT 

EN1        DO HEAD

           DO CHOICE

EXIT       DO EXIT^ACMSRT1

 +1        QUIT 

HEAD       DO HEAD^ACMMENU

 +1        SET ACMX="REPORT SORTING UTILITY"

 +2        WRITE !!?80-$LENGTH(ACMX)\2,ACMX,!!?10,"The ",@ACMRVON,ACMRPT,@ACMRVOFF," report can be sorted by one or more",!?10,"of the following attributes.  '<==' indicates a mandatory selection.",!

 +3        KILL ACMX,ACMFORC

 +4        QUIT 

CHOICE     DO M2

C1         IF $DATA(ACMXZ)

               WRITE !!?10,"Sorting by: ",ACMXZ

 +1        SET DIR(0)="NOA^1:"_$SELECT(ACMYI>1:ACMYI,1:1)

           SET DIR("A")="          Your choice: "

           SET DIR("?")="Type "_$SELECT(ACMYI>1:"a number from 1",1:"number 1: ")_$SELECT(ACMYI>1:"-"_ACMYI_":",1:"")

 +2        WRITE !

 +3        DO ^DIR

           KILL DIR

 +4        IF $EXTRACT(X)=U!(X="")

               SET ACMQUIT=""

               QUIT 

 +5        IF ACMUB(Y)=""

               WRITE !!,"Already selected as a sort criterion."

               GOTO C1

 +6        SET ACMZZ=Y

 +7        IF 'ACMZZ

               GOTO CHOICE

OK         IF '$DATA(ACMXZ)

               SET ACMXZ=""

 +1        SET ACMYZ=ACMU(ACMZZ)

           SET (X,ACMSNO)=+ACMYZ

           SET ACMSNA=$PIECE(ACMYZ,U,2)

           SET ACMCSTG=ACMCSTG_ACMZZ_U

           SET ACMXZ=ACMXZ_$SELECT(ACMXZ'="":", then ",1:"")_ACMSNA

 +2        KILL ACMYZ

 +3        SET ACMUB(ACMZZ)=""

 +4        WRITE "   ",ACMSNA

OK1        IF BY'=""

               SET BY=BY_","

 +1        SET ACMNAV=^ACM(48.5,X,0)

 +2       ;IHS/CIM/THL PATCH 4

           IF $DATA(ACMDM)

               IF $PIECE(^ACM(48.5,X,0),U,5)["41,"

                   FOR ACMJ=42,43,44,45,46,47,48,49,51,53,57

                       IF ACMFILE=ACMJ

                           IF (($PIECE(^ACM(48.5,X,0),U,2)="P"!($PIECE(^(0),U,2)="D")!($PIECE(^(0),U,2)="A")))!(ACMSNA["STATUS")

                               SET BY=BY_"REGISTER:,"

                               QUIT 

 +3        IF ACMSNA["APPOINT"

               IF ACMFILE=41

                   SET BY=BY_"CMS APPOINTMENT:,"

 +4        IF ACMSNA["REGISTER-"

               SET BY=BY_"REGISTER,"

 +5        KILL ACMJ

 +6        SET BY=BY_^ACM(48.5,X,3)

 +7        IF BY["EDITED NOT PRINTED"

               SET BY="[ACM EDITED NOT PRINTED]"

               SET DIC=ACMDIC

               KILL FR,TO

               DO PRT1

               SET ACMQUIT=""

               QUIT 

 +8        DO @("S"_$PIECE(ACMNAV,U,2)_"^ACMSRT1")

 +9        KILL ACMNAV

 +10       IF $DATA(ACMQUIT)

               QUIT 

 +11       IF $DATA(ACMFORC)

               KILL ACMFORC

               DO PRINT

               QUIT 

 +12       IF BY["["

               SET BY="["_$PIECE(BY,"[",2)

               SET BY=$PIECE(BY,"]")_"]"

               DO PRINT

               QUIT 

 +13       IF ACMYI<2

               DO PRINT

               QUIT 

 +14       WRITE !!,"Within ",ACMSNA,", want to sort by another attribute"

 +15       SET %=2

           DO YN^DICN

 +16       IF %Y=U

               SET ACMQUIT=""

               QUIT 

 +17       IF "Nn"[$EXTRACT(%Y)

               DO CHECK

               IF $DATA(ACMFORC)

                   GOTO OK

               DO PRINT

               QUIT 

 +18       WRITE !!!

 +19       SET ACMN=ACMN+1

 +20       GOTO EN1

M2         KILL ACMU

 +1        SET ACMYII=ACMYI\2+(ACMYI#2)

 +2        SET (ACMJ,ACMZ)=0

 +3        FOR ACMJ=1:1:ACMYII

               Begin DoDot:1

 +4                IF ACMUB(ACMJ)'=""

                       Begin DoDot:2

 +5                        SET (ACMU(ACMJ),ACMSRT)=ACMUB(ACMJ)

                           SET X=$PIECE(ACMSRT,U,2)

                           SET Y=$PIECE(ACMSRT,U)

                           SET ACMYZ=$PIECE(ACMSRT,U,3)

 +6                        WRITE !?8,$JUSTIFY(ACMJ,3),") ",X

                           IF ACMYZ

                               WRITE " <=="

                               SET ACMMAND=ACMJ

                               SET ACMMANN=X

                               SET ACMMAN=Y_U_X

                       End DoDot:2

 +7               IF '$TEST

                       WRITE !?8,$JUSTIFY(ACMJ,3),") "

 +8                IF $DATA(ACMUB(ACMJ+ACMYII))

                       Begin DoDot:2

 +9                        SET ACMJ1=ACMJ+ACMYII

 +10                       SET (ACMU(ACMJ1),ACMSRT)=ACMUB(ACMJ1)

                           SET X=$PIECE(ACMSRT,U,2)

                           SET Y=$PIECE(ACMSRT,U)

                           SET ACMYZ=$PIECE(ACMSRT,U,3)

 +11                       WRITE ?45,$JUSTIFY(ACMJ1,3),") ",X

                           IF ACMYZ

                               WRITE " <=="

                               SET ACMMAND=ACMJ1

                               SET ACMMANN=X

                               SET ACMMAN=Y_U_X

                       End DoDot:2

 +12              IF '$TEST

                       IF $DATA(ACMJ1)

                           IF $DATA(ACMUB(ACMJ1+1))

                               WRITE ?45,$JUSTIFY(ACMJ1,3),") "

               End DoDot:1

 +13       KILL ACMSRT,ACMZ,ACMYZ

 +14       QUIT 

PS         IF ACMRPT["RECALL LETTERS"

               SET ACMX="P"

               QUIT 

 +1        DO PS^ACMSRT1

 +2        QUIT 

PRINT      IF $DATA(ACMPP)

               IF $DATA(ACMDM)

                   IF ((ACMFILE'=41)&(ACMFILE'=48))

                       DO PS

                       IF $DATA(ACMQUIT)

                           QUIT 

PRNT       SET DIC=ACMDIC

 +1        IF $DATA(ACMDM)

               IF DIC["41"

                   IF BY'["STATUS"

                       SET BY="@STATUS,"_BY

                       SET TO="ACTIVE,"_TO

                       SET FR="ACTIVE,"_FR

 +2        IF $DATA(ACMDM)

               IF DIC["41"

                   SET BY="@NAME OF REGISTER,"_BY

                   SET TO=ACMRGNA_","_TO

                   SET FR=ACMRGNA_","_FR

                   GOTO PRT1

 +3       ;IHS/CIM/THL PATCH 4

           IF $DATA(ACMDM)

               IF DIC'["41"

                   FOR ACMJ=42,43,44,45,46,47,48,49,51,53,57

                       IF ACMFILE=ACMJ

                           IF BY'["STATUS"

                               SET BY="REGISTER:,@STATUS,"_BY

                               SET TO="ACTIVE,"_TO

                               SET FR="ACTIVE,"_FR

                           QUIT 

 +4        IF $DATA(ACMDM)

               IF DIC'["41"

                   FOR ACMJ=42,43,44,45,46,47,48,49,51,53,57

                       IF ACMFILE=ACMJ

                           SET BY="@NAME OF REGISTER,"_BY

                           SET TO=ACMRGNA_","_TO

                           SET FR=ACMRGNA_","_FR

                           QUIT 

 +5        KILL ACMJ

PRT1       IF ACMDIC'["."

               SET ACMSDIC=$PIECE(ACMDIC,",")_")"

               IF $EXTRACT(ACMENTRY,1,4)'="APPL"

                   DO ^ACMSTMP

 +1        DO ZIS

 +2        IF $DATA(ACMQUIT)

               KILL ACMQUIT

               QUIT 

 +3        SET DIOEND="W:IOST[""C-"" !!,""End of report.  Strike <CR> to continue."" R:IOST[""C-"" ACMX:300 W:$D(IOF) @IOF"

 +4        WRITE !

           DO WAIT^DICD

           WRITE !

 +5        SET IOP=ION

DIP        SET DIC=ACMDIC

           SET DC=0

 +1        DO EN1^DIP

 +2        DO ^%ZISC

 +3        QUIT 

ZIS        IF $EXTRACT(ACMENTRY,1,3)="MPS"

               SET DIR(0)="YO"

               SET DIR("A")="Include PCC HEALTH SUMMARY"

               SET DIR("B")="NO"

               WRITE !

               DO ^DIR

               KILL DIR

               IF Y=1

                   SET ACMMHS=""

                   DO SELTYP^ACMPPDTX

 +1        IF $EXTRACT(ACMENTRY,1,4)="APPL"

               SET DIR(0)="YO"

               SET DIR("A")="Do you want to VIEW the Standard Letter before printing"

               SET DIR("B")="NO"

               WRITE !

               DO ^DIR

               KILL DIR

               IF Y=1

                   WRITE !

                   SET ACMBY=BY

                   SET ACMFR=FR

                   SET ACMTO=TO

                   SET ACMFLDS=FLDS

                   DO ^ACMLTR2

                   IF ACMLTREX=1

                       GOTO ACMLTREX

                   Begin DoDot:1

 +2                    SET DIC=ACMDIC

                       SET BY=ACMBY

                       SET FLDS=ACMFLDS

                       SET L=0

                       SET FR=ACMFR

                       SET TO=ACMTO

                       KILL ACMBY,ACMFLDS,ACMFR,ACMTO

 +3                    QUIT 

                   End DoDot:1

 +4        KILL IOP

 +5        SET %ZIS="PMNQ"

 +6        WRITE !

 +7        KILL IOP

 +8        DO ^%ZIS

 +9        IF POP

               GOTO DONE

 +10       IF ION["HOST"

               SET %ZIS("IOPAR")=IOPAR

 +11       IF IO=IO(0)

               IF $DATA(IO("Q"))

                   WRITE !,"Cannot Queue to Screen or Slave Printer!",!

                   KILL IO("Q")

                   GOTO ZIS

 +12      ;I IO'=IO(0),'$D(IO("Q")) W !,"I will QUEUE this report to run for you now." S IO("Q")=1

 +13       IF $DATA(IO("Q"))

               DO TSK

               SET ACMQUIT=""

 +14       QUIT 

TSK        SET ZTRTN="DIP^ACMSRT"

           SET DIC=ACMDIC

           SET IOP=ION

 +1        SET ZTSAVE("*")=""

 +2        SET ZTDESC="CMS REPORT"

           SET ZTIO=IO

 +3        DO ^%ZTLOAD

 +4        WRITE !,"REQUEST QUEUED!"

 +5        KILL IO("Q"),ZTSK

DONE       IF '$DATA(ZTQUEUED)

               DO ^%ZISC

 +1        SET ACMQUIT=""

 +2        QUIT 

CHECK      IF ACMCSTG[(U_ACMMAND_U)

               QUIT 

 +1        SET ACMZZ=ACMMAND

           SET ACMFORC=""

           SET ACMN=ACMN+1

 +2        WRITE !!,*7,"You must also sort by"

 +3        QUIT 

ENTRY     ;EP;VARIABLE TO CONTROL SORT

 +1        SET ACMENTRY=$TEXT(@ACMENTRY^ACMCTRL1)

           GOTO EN

 +2       ;

ACMLTREX  ;Exit if User doesn't want to print letter

 +1        KILL ACMLTREX

           GOTO DONE

 +2       ;

BACKEXIT  ;Tmp qued in bckgrnd

 +1        KILL ACMBACK

           GOTO DONE

 +2       ;

AMPM(FMDT) ;EP; return fileman date in AM/PM

 +1       ;IHS/CMI/TMJ PATCH #6

 +2        IF $PIECE(FMDT,".",2)=""

               QUIT $$FMTE^XLFDT(FMDT)

 +3        IF $LENGTH($PIECE(FMDT,"."))'=7

               QUIT ""

 +4        SET FMTE=$$FMTE^XLFDT(FMDT)

 +5        SET FMTED=$PIECE(FMTE,"@")

 +6        SET FMTEMC=$PIECE(FMTE,"@",2)

 +7        SET FMTEH=$EXTRACT(FMTEMC,1,2)

 +8        SET FMTEM=$EXTRACT(FMTEMC,4,5)

 +9        IF FMTEH=12

               QUIT FMTED_"@"_FMTEH_":"_FMTEM_" PM"

 +10       IF FMTEH="00"

               QUIT FMTED_"@12:"_FMTEM_" AM"

 +11       IF FMTEH>12

               QUIT FMTED_"@"_(FMTEH-12)_":"_FMTEM_" PM"

 +12       QUIT FMTED_"@"_FMTEH_":"_FMTEM_" AM"

 +13       QUIT