- ACMRL1 ; IHS/TUCSON/TMJ - PROCESS LISTER ; [ 06/01/1999 1:48 PM ]
- ;;2.0;ACM CASE MANAGEMENT SYSTEM;**1**;JAN 10, 1996
- ;IHS/CMI/LAB - patch 1 tmp to xtmp
- ;
- ;
- ;
- START ;
- S (ACMBT,ACMBTH)=$H,ACMJOB=$J,ACMRCNT=0
- S ^XTMP("ACMRL",0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"CASE MANAGEMENT GENERAL RETRIEVAL"
- D P
- Q
- ;
- P ;
- S DFN=0 F S DFN=$O(^ACM(41,"AC",DFN)) Q:DFN'=+DFN I $D(^ACM(41,"AC",DFN,ACMRG)),'$P(^DPT(DFN,0),U,19) S ACMIFN=^ACM(41,"AC",DFN,ACMRG) D PROC
- Q
- ;
- ;
- END ;
- S ACMET=$H
- D EOJ
- Q
- EOJ ;
- Q
- PROC ;
- D SCREENS
- Q:$D(ACMSKIP)
- K ACMSRT,ACMPRNT S ACMCRIT=ACMSORT,ACMX=0
- X:$D(^ACM(58.1,ACMSORT,4)) ^ACM(58.1,ACMSORT,4) I $G(ACMPRNT)="" S ACMPRNT="--"
- S ACMSRT=ACMPRNT
- S ^XTMP("ACMRL",ACMJOB,ACMBTH,"DATA HITS",ACMSRT,DFN)="",ACMRCNT=ACMRCNT+1
- Q:$D(^XTMP("ACMRL",ACMJOB,ACMBTH,"PATIENTS",DFN))!($D(ACMSCNT))
- S ^XTMP("ACMRL",ACMJOB,ACMBTH,"PATIENTS",DFN)="",ACMPTCT=ACMPTCT+1
- Q
- SCREENS ;
- K ACMSKIP
- S ACMI=0 F S ACMI=$O(^ACM(58.8,ACMRPT,11,ACMI)) Q:ACMI'=+ACMI!($D(ACMSKIP)) D
- .I '$P(^ACM(58.1,ACMI,0),U,8) D SINGLE Q
- .D MULT
- .Q
- Q
- SINGLE ;
- K X,ACMSPEC S X="",ACMX=0
- X:$D(^ACM(58.1,ACMI,1)) ^(1)
- I X="" S ACMSKIP="" Q
- I '$D(ACMSPEC),'$D(^ACM(58.8,ACMRPT,11,ACMI,11,"B",X)) S ACMSKIP="" Q
- Q
- MULT ;
- K ACMFOUN,ACMSKIP,ACMSPEC,X S ACMX=0,X=""
- X:$D(^ACM(58.1,ACMI,1)) ^(1)
- I $O(X(""))="" S ACMSKIP="" Q
- I '$D(ACMSPEC) S Y="" F S Y=$O(X(Y)) Q:Y="" I $D(^ACM(58.8,ACMRPT,11,ACMI,11,"B",Y)) S ACMFOUN="" Q
- I $D(ACMSPEC),$D(X) S ACMFOUN=1 Q
- S:'$D(ACMFOUN) ACMSKIP=""
- Q
- XIT ;EP - CALLED FROM ACMRL
- K ACMBD,ACMBDD,ACMED,ACMEDD,ACMSD,ACMSORT,ACMSORV,ACMTCW,ACMRPT,ACMLHDR,ACMDISP,%H,ACMET,ACMLINE,ACMPRNM,ACMPRNT,ACMSKIP,ACMTYPE,ACMSPAG,ACMEN1,ACMSEAT,ACMPROC,ACM,ACMCAND,ACMHDR,ACMHEAD,ACMIFN,ACMNCAN
- K ACMCTYP,ACMFLG,ACMG,ACMNAME,ACMNIFN,ACMSAVE,ACMTITL,ACMQUIT,ACMPCNT,ACMQFLG,ACMPTCT,ACMTL,ACMSRTR,ACMSRTV
- K C,D,D0,DA,DIC,DD,DFN,DIADD,DLAYGO,DICR,DIE,DIK,DINUM,DIQ,DIR,DIRUT,DUOUT,DHD,DTOUT,DR,J,I,J,K,M,S,TS,X,Y,DIG,DIH,DIV,DQ,DDH,AMQQEN3,AMQQLX,DHIT
- XIT1 ;EP
- K ACMANS,ACMBTH,ACMC,ACMCNT,ACMCRIT,ACMCUT,ACMD,ACMDISP,ACMDONE,ACMHIGH,ACMI,ACMJOB,ACMQMAN,ACMSEL,ACMTEXT,ACMVAR,ACMSKIP,ACMPRNT,ACMPRNM,ACMLINE,ACMRCNT,ACMSCNT,ACMDFET,ACMY,DFN
- K X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M,ZTIO,DUOUT,DIR,DTOUT,V,Z,I,DIC,DIK,DIADD,DLAYGO,DA,DR,DIE,DIU,AMQQTAX,DINUM,ACMPACK,ACMEP1,ACMEP2,D,ACMLENG,ACMLHDR,ACMSAVE
- Q
- ACMRL1 ; IHS/TUCSON/TMJ - PROCESS LISTER ; [ 06/01/1999 1:48 PM ]
- +1 ;;2.0;ACM CASE MANAGEMENT SYSTEM;**1**;JAN 10, 1996
- +2 ;IHS/CMI/LAB - patch 1 tmp to xtmp
- +3 ;
- +4 ;
- +5 ;
- START ;
- +1 SET (ACMBT,ACMBTH)=$HOROLOG
- SET ACMJOB=$JOB
- SET ACMRCNT=0
- +2 SET ^XTMP("ACMRL",0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"CASE MANAGEMENT GENERAL RETRIEVAL"
- +3 DO P
- +4 QUIT
- +5 ;
- P ;
- +1 SET DFN=0
- FOR
- SET DFN=$ORDER(^ACM(41,"AC",DFN))
- IF DFN'=+DFN
- QUIT
- IF $DATA(^ACM(41,"AC",DFN,ACMRG))
- IF '$PIECE(^DPT(DFN,0),U,19)
- SET ACMIFN=^ACM(41,"AC",DFN,ACMRG)
- DO PROC
- +2 QUIT
- +3 ;
- +4 ;
- END ;
- +1 SET ACMET=$HOROLOG
- +2 DO EOJ
- +3 QUIT
- EOJ ;
- +1 QUIT
- PROC ;
- +1 DO SCREENS
- +2 IF $DATA(ACMSKIP)
- QUIT
- +3 KILL ACMSRT,ACMPRNT
- SET ACMCRIT=ACMSORT
- SET ACMX=0
- +4 IF $DATA(^ACM(58.1,ACMSORT,4))
- XECUTE ^ACM(58.1,ACMSORT,4)
- IF $GET(ACMPRNT)=""
- SET ACMPRNT="--"
- +5 SET ACMSRT=ACMPRNT
- +6 SET ^XTMP("ACMRL",ACMJOB,ACMBTH,"DATA HITS",ACMSRT,DFN)=""
- SET ACMRCNT=ACMRCNT+1
- +7 IF $DATA(^XTMP("ACMRL",ACMJOB,ACMBTH,"PATIENTS",DFN))!($DATA(ACMSCNT))
- QUIT
- +8 SET ^XTMP("ACMRL",ACMJOB,ACMBTH,"PATIENTS",DFN)=""
- SET ACMPTCT=ACMPTCT+1
- +9 QUIT
- SCREENS ;
- +1 KILL ACMSKIP
- +2 SET ACMI=0
- FOR
- SET ACMI=$ORDER(^ACM(58.8,ACMRPT,11,ACMI))
- IF ACMI'=+ACMI!($DATA(ACMSKIP))
- QUIT
- Begin DoDot:1
- +3 IF '$PIECE(^ACM(58.1,ACMI,0),U,8)
- DO SINGLE
- QUIT
- +4 DO MULT
- +5 QUIT
- End DoDot:1
- +6 QUIT
- SINGLE ;
- +1 KILL X,ACMSPEC
- SET X=""
- SET ACMX=0
- +2 IF $DATA(^ACM(58.1,ACMI,1))
- XECUTE ^(1)
- +3 IF X=""
- SET ACMSKIP=""
- QUIT
- +4 IF '$DATA(ACMSPEC)
- IF '$DATA(^ACM(58.8,ACMRPT,11,ACMI,11,"B",X))
- SET ACMSKIP=""
- QUIT
- +5 QUIT
- MULT ;
- +1 KILL ACMFOUN,ACMSKIP,ACMSPEC,X
- SET ACMX=0
- SET X=""
- +2 IF $DATA(^ACM(58.1,ACMI,1))
- XECUTE ^(1)
- +3 IF $ORDER(X(""))=""
- SET ACMSKIP=""
- QUIT
- +4 IF '$DATA(ACMSPEC)
- SET Y=""
- FOR
- SET Y=$ORDER(X(Y))
- IF Y=""
- QUIT
- IF $DATA(^ACM(58.8,ACMRPT,11,ACMI,11,"B",Y))
- SET ACMFOUN=""
- QUIT
- +5 IF $DATA(ACMSPEC)
- IF $DATA(X)
- SET ACMFOUN=1
- QUIT
- +6 IF '$DATA(ACMFOUN)
- SET ACMSKIP=""
- +7 QUIT
- XIT ;EP - CALLED FROM ACMRL
- +1 KILL ACMBD,ACMBDD,ACMED,ACMEDD,ACMSD,ACMSORT,ACMSORV,ACMTCW,ACMRPT,ACMLHDR,ACMDISP,%H,ACMET,ACMLINE,ACMPRNM,ACMPRNT,ACMSKIP,ACMTYPE,ACMSPAG,ACMEN1,ACMSEAT,ACMPROC,ACM,ACMCAND,ACMHDR,ACMHEAD,ACMIFN,ACMNCAN
- +2 KILL ACMCTYP,ACMFLG,ACMG,ACMNAME,ACMNIFN,ACMSAVE,ACMTITL,ACMQUIT,ACMPCNT,ACMQFLG,ACMPTCT,ACMTL,ACMSRTR,ACMSRTV
- +3 KILL C,D,D0,DA,DIC,DD,DFN,DIADD,DLAYGO,DICR,DIE,DIK,DINUM,DIQ,DIR,DIRUT,DUOUT,DHD,DTOUT,DR,J,I,J,K,M,S,TS,X,Y,DIG,DIH,DIV,DQ,DDH,AMQQEN3,AMQQLX,DHIT
- XIT1 ;EP
- +1 KILL ACMANS,ACMBTH,ACMC,ACMCNT,ACMCRIT,ACMCUT,ACMD,ACMDISP,ACMDONE,ACMHIGH,ACMI,ACMJOB,ACMQMAN,ACMSEL,ACMTEXT,ACMVAR,ACMSKIP,ACMPRNT,ACMPRNM,ACMLINE,ACMRCNT,ACMSCNT,ACMDFET,ACMY,DFN
- +2 KILL X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M,ZTIO,DUOUT,DIR,DTOUT,V,Z,I,DIC,DIK,DIADD,DLAYGO,DA,DR,DIE,DIU,AMQQTAX,DINUM,ACMPACK,ACMEP1,ACMEP2,D,ACMLENG,ACMLHDR,ACMSAVE
- +3 QUIT
