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
