APCLVL1 ; IHS/CMI/LAB - PROCESS VISIT LIST ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;
;
START ;
S (APCLBT,APCLBTH)=$H,APCLJOB=$J,APCLRCNT=0
D XTMP^APCLOSUT("APCLVL","PCC GENERAL RETRIEVAL")
D @APCLTYPE,END
Q
;
VP ;run with search template of patients, visit gen
S X1=APCLBD,X2=-1 D C^%DTC S APCLSD=X
S APCLODAT=APCLSD_".9999" F S APCLODAT=$O(^AUPNVSIT("B",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>APCLED) D VP1
Q
VP1 ;
S APCLVIEN="" F S APCLVIEN=$O(^AUPNVSIT("B",APCLODAT,APCLVIEN)) Q:APCLVIEN'=+APCLVIEN I $D(^AUPNVSIT(APCLVIEN,0)),$P(^(0),U,9),'$P(^(0),U,11) S DFN=$P(^AUPNVSIT(APCLVIEN,0),U,5) D
.Q:'$D(^DIBT(APCLSEAT,1,DFN)) ;quit if patient not in search template
.D PROC
.Q
Q
VR ;run withREGISTER of patients, visit gen
S X1=APCLBD,X2=-1 D C^%DTC S APCLSD=X
S APCLODAT=APCLSD_".9999" F S APCLODAT=$O(^AUPNVSIT("B",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>APCLED) D VR1
Q
VR1 ;
S APCLVIEN="" F S APCLVIEN=$O(^AUPNVSIT("B",APCLODAT,APCLVIEN)) Q:APCLVIEN'=+APCLVIEN I $D(^AUPNVSIT(APCLVIEN,0)),$P(^(0),U,9),'$P(^(0),U,11) S DFN=$P(^AUPNVSIT(APCLVIEN,0),U,5) D
.Q:'$D(^ACM(41,"AC",DFN,APCLCMSR)) ;quit if patient not in REGISTER
.S I=^ACM(41,"AC",DFN,APCLCMSR)
.I $D(APCLCMSS) S S=$P($G(^ACM(41,I,"DT")),U) Q:S="" Q:'$D(APCLCMSS(S))
.D PROC
.Q
Q
VV ;run by search template
S APCLVIEN=0 F S APCLVIEN=$O(^DIBT(APCLSEAT,1,APCLVIEN)) Q:APCLVIEN'=+APCLVIEN I $D(^AUPNVSIT(APCLVIEN,0)),$P(^(0),U,9),'$P(^(0),U,11) D
.S X=$P($P(^AUPNVSIT(APCLVIEN,0),U),".")
.Q:X>APCLED
.Q:X<APCLBD
.D PROC
.Q
Q
VS ; Run by visit date
S X1=APCLBD,X2=-1 D C^%DTC S APCLSD=X
S APCLODAT=APCLSD_".9999" F S APCLODAT=$O(^AUPNVSIT("B",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>APCLED) D V1
Q
;
PP ;
S APCLVIEN=0 F S APCLVIEN=$O(^DPT(APCLVIEN)) Q:APCLVIEN'=+APCLVIEN I '$P(^DPT(APCLVIEN,0),U,19),'$$DEMO^APCLUTL(APCLVIEN,$G(APCLDEMO)) D PROC
;S APCLVIEN=1040 F S APCLVIEN=$O(^DPT(APCLVIEN)) Q:APCLVIEN>1041 I '$P(^DPT(APCLVIEN,0),U,19),$$DEMO^APCLUTL(APCLVIEN) D PROC
Q
;
PS ;
S APCLVIEN=0 F S APCLVIEN=$O(^DIBT(APCLSEAT,1,APCLVIEN)) Q:APCLVIEN'=+APCLVIEN I $D(^DPT(APCLVIEN,0)),'$P(^(0),U,19) D PROC
Q
;
PR ; register
S APCLCMSV=0 F S APCLCMSV=$O(^ACM(41,"B",APCLCMSR,APCLCMSV)) Q:APCLCMSV'=+APCLCMSV D
.I $D(APCLCMSS) S S=$P($G(^ACM(41,APCLCMSV,"DT")),U) Q:S="" Q:'$D(APCLCMSS(S))
.S APCLVIEN=$P(^ACM(41,APCLCMSV,0),U,2)
.D PROC
.Q
Q
END ;
S APCLET=$H
Q
V1 ;
S APCLVIEN="" F S APCLVIEN=$O(^AUPNVSIT("B",APCLODAT,APCLVIEN)) Q:APCLVIEN'=+APCLVIEN I $D(^AUPNVSIT(APCLVIEN,0)),$P(^(0),U,9),'$P(^(0),U,11),'$$DEMO^APCLUTL($P(^AUPNVSIT(APCLVIEN,0),U,5),$G(APCLDEMO)) D PROC
Q
PROC ;
K APCLSPEC
I APCLPTVS="V" S APCLVREC=^AUPNVSIT(APCLVIEN,0),DFN=$P(APCLVREC,U,5)
I APCLPTVS="P" S DFN=APCLVIEN
Q:'$D(^DPT(DFN,0))
Q:'$D(^AUPNPAT(DFN,0))
Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
D SCREENS
Q:$D(APCLSKIP)
K APCLSRT,APCLPRNT S APCLCRIT=APCLSORT,APCLX=0
X:$D(^APCLVSTS(APCLSORT,4)) ^APCLVSTS(APCLSORT,4) I '$D(APCLPRNT) D
. I APCLPTVS="V" S Y=$P($P(APCLVREC,U),".") S APCLPRNT=Y Q
. S APCLPRNT=$P(^DPT(DFN,0),U)
.Q
S APCLSRT=APCLPRNT
D SUBPAT
S ^XTMP("APCLVL",APCLJOB,APCLBTH,"DATA HITS",APCLSRT,APCLVIEN)="",APCLRCNT=APCLRCNT+1
Q:$D(^XTMP("APCLVL",APCLJOB,APCLBTH,"PATIENTS",DFN))
S ^XTMP("APCLVL",APCLJOB,APCLBTH,"PATIENTS",DFN)="",APCLPTCT=APCLPTCT+1
Q
SUBPAT ;tally # of patients by sort value on detailed/subtotal
Q:APCLCTYP="C"
Q:APCLCTYP="P"
Q:APCLCTYP="F"
Q:APCLCTYP="T"
Q:APCLCTYP="L"
S:$G(APCLSRT)="" APCLSRT="????"
Q:$D(^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PATIENT HIT",APCLSRT,DFN))
S:'$D(^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRT)) ^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRT)=0
S ^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRT)=^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRT)+1
Q:$D(^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PATIENT HIT",APCLSRT,DFN))
S ^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PATIENT HIT",APCLSRT,DFN)=""
Q
SCREENS ;
K APCLSKIP
S APCLI=0 F S APCLI=$O(^APCLVRPT(APCLRPT,11,APCLI)) Q:APCLI'=+APCLI!($D(APCLSKIP)) D
.I '$P(^APCLVSTS(APCLI,0),U,8) D SINGLE Q
.D MULT
.Q
Q
SINGLE ;
K X,APCLSPEC S X="",APCLX=0
X:$D(^APCLVSTS(APCLI,1)) ^(1)
I X="" S APCLSKIP="" Q
I '$D(APCLSPEC),'$D(^APCLVRPT(APCLRPT,11,APCLI,11,"B",X)) S APCLSKIP="" Q
Q
MULT ;
K APCLFOUN,APCLSKIP,APCLSPEC,X S APCLX=0,X=""
X:$D(^APCLVSTS(APCLI,1)) ^(1)
I $O(X(""))="" S APCLSKIP="" Q
I '$D(APCLSPEC) S Y="" F S Y=$O(X(Y)) Q:Y="" I $D(^APCLVRPT(APCLRPT,11,APCLI,11,"B",Y)) S APCLFOUN="" Q
I $D(APCLSPEC),$G(X) S APCLFOUN=1 Q
S:'$D(APCLFOUN) APCLSKIP=""
Q
XIT ;EP - CALLED FROM APCLVL
K APCLBD,APCLBDD,APCLED,APCLEDD,APCLSD,APCLSORT,APCLSORV,APCLTCW,APCLRPT,APCLLHDR,APCLDISP,%H,APCLET,APCLLINE,APCLPRNM,APCLPRNT,APCLSKIP,APCLTYPE,APCLSPAG,APCLEN1,APCLSEAT,APCLPTVS,APCL,APCLCAND,APCLHDR,APCLHEAD,APCLSPEC,APCLOPT
K APCLCTYP,APCLFLG,APCLG,APCLNAME,APCLNIFN,APCLSAVE,APCLTITL,APCLQUIT,APCLPCNT,APCLQFLG,APCLPTCT,APCLTL,APCLSRTR,APCLSRTV,APCLFILE,APCLJD,APCLFCNT,APCLX1,APCLX2,APCLSDAT
K C,D,D0,DA,DIC,DD,DFN,DIADD,DLAYGO,DICR,DIE,DIK,DINUM,DIQ,DIR,DIRUT,DUOUT,DTOUT,DR,J,I,J,K,M,S,TS,X,Y,DIG,DIH,DIV,DQ,DDH,AMQQEN3,AMQQLX
XIT1 ;EP
K APCLANS,APCLBTH,APCLC,APCLCNT,APCLCRIT,APCLCUT,APCLD,APCLDISP,APCLDONE,APCLHIGH,APCLI,APCLJOB,APCLQMAN,APCLSEL,APCLTEXT,APCLVAR,APCLSKIP,APCLPRNT,APCLPRNM,APCLLINE,APCLRCNT,APCLSCNT,APCLDFET,APCLY,DFN
K X,X1,X2,IO("Q"),%,Y,POP,DIRUT,H,S,TS,M,DUOUT,DIR,DTOUT,V,Z,I,DIC,DIK,DIADD,DLAYGO,DA,DR,DIE,DIU,AMQQTAX,DINUM,APCLPACK,APCLEP1,APCLEP2,D,APCLLENG,APCLLHDR,APCLSAVE,AMQQND
Q
APCLVL1 ; IHS/CMI/LAB - PROCESS VISIT LIST ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;
+4 ;
START ;
+1 SET (APCLBT,APCLBTH)=$HOROLOG
SET APCLJOB=$JOB
SET APCLRCNT=0
+2 DO XTMP^APCLOSUT("APCLVL","PCC GENERAL RETRIEVAL")
+3 DO @APCLTYPE
DO END
+4 QUIT
+5 ;
VP ;run with search template of patients, visit gen
+1 SET X1=APCLBD
SET X2=-1
DO C^%DTC
SET APCLSD=X
+2 SET APCLODAT=APCLSD_".9999"
FOR
SET APCLODAT=$ORDER(^AUPNVSIT("B",APCLODAT))
IF APCLODAT=""!((APCLODAT\1)>APCLED)
QUIT
DO VP1
+3 QUIT
VP1 ;
+1 SET APCLVIEN=""
FOR
SET APCLVIEN=$ORDER(^AUPNVSIT("B",APCLODAT,APCLVIEN))
IF APCLVIEN'=+APCLVIEN
QUIT
IF $DATA(^AUPNVSIT(APCLVIEN,0))
IF $PIECE(^(0),U,9)
IF '$PIECE(^(0),U,11)
SET DFN=$PIECE(^AUPNVSIT(APCLVIEN,0),U,5)
Begin DoDot:1
+2 ;quit if patient not in search template
IF '$DATA(^DIBT(APCLSEAT,1,DFN))
QUIT
+3 DO PROC
+4 QUIT
End DoDot:1
+5 QUIT
VR ;run withREGISTER of patients, visit gen
+1 SET X1=APCLBD
SET X2=-1
DO C^%DTC
SET APCLSD=X
+2 SET APCLODAT=APCLSD_".9999"
FOR
SET APCLODAT=$ORDER(^AUPNVSIT("B",APCLODAT))
IF APCLODAT=""!((APCLODAT\1)>APCLED)
QUIT
DO VR1
+3 QUIT
VR1 ;
+1 SET APCLVIEN=""
FOR
SET APCLVIEN=$ORDER(^AUPNVSIT("B",APCLODAT,APCLVIEN))
IF APCLVIEN'=+APCLVIEN
QUIT
IF $DATA(^AUPNVSIT(APCLVIEN,0))
IF $PIECE(^(0),U,9)
IF '$PIECE(^(0),U,11)
SET DFN=$PIECE(^AUPNVSIT(APCLVIEN,0),U,5)
Begin DoDot:1
+2 ;quit if patient not in REGISTER
IF '$DATA(^ACM(41,"AC",DFN,APCLCMSR))
QUIT
+3 SET I=^ACM(41,"AC",DFN,APCLCMSR)
+4 IF $DATA(APCLCMSS)
SET S=$PIECE($GET(^ACM(41,I,"DT")),U)
IF S=""
QUIT
IF '$DATA(APCLCMSS(S))
QUIT
+5 DO PROC
+6 QUIT
End DoDot:1
+7 QUIT
VV ;run by search template
+1 SET APCLVIEN=0
FOR
SET APCLVIEN=$ORDER(^DIBT(APCLSEAT,1,APCLVIEN))
IF APCLVIEN'=+APCLVIEN
QUIT
IF $DATA(^AUPNVSIT(APCLVIEN,0))
IF $PIECE(^(0),U,9)
IF '$PIECE(^(0),U,11)
Begin DoDot:1
+2 SET X=$PIECE($PIECE(^AUPNVSIT(APCLVIEN,0),U),".")
+3 IF X>APCLED
QUIT
+4 IF X<APCLBD
QUIT
+5 DO PROC
+6 QUIT
End DoDot:1
+7 QUIT
VS ; Run by visit date
+1 SET X1=APCLBD
SET X2=-1
DO C^%DTC
SET APCLSD=X
+2 SET APCLODAT=APCLSD_".9999"
FOR
SET APCLODAT=$ORDER(^AUPNVSIT("B",APCLODAT))
IF APCLODAT=""!((APCLODAT\1)>APCLED)
QUIT
DO V1
+3 QUIT
+4 ;
PP ;
+1 SET APCLVIEN=0
FOR
SET APCLVIEN=$ORDER(^DPT(APCLVIEN))
IF APCLVIEN'=+APCLVIEN
QUIT
IF '$PIECE(^DPT(APCLVIEN,0),U,19)
IF '$$DEMO^APCLUTL(APCLVIEN,$GET(APCLDEMO))
DO PROC
+2 ;S APCLVIEN=1040 F S APCLVIEN=$O(^DPT(APCLVIEN)) Q:APCLVIEN>1041 I '$P(^DPT(APCLVIEN,0),U,19),$$DEMO^APCLUTL(APCLVIEN) D PROC
+3 QUIT
+4 ;
PS ;
+1 SET APCLVIEN=0
FOR
SET APCLVIEN=$ORDER(^DIBT(APCLSEAT,1,APCLVIEN))
IF APCLVIEN'=+APCLVIEN
QUIT
IF $DATA(^DPT(APCLVIEN,0))
IF '$PIECE(^(0),U,19)
DO PROC
+2 QUIT
+3 ;
PR ; register
+1 SET APCLCMSV=0
FOR
SET APCLCMSV=$ORDER(^ACM(41,"B",APCLCMSR,APCLCMSV))
IF APCLCMSV'=+APCLCMSV
QUIT
Begin DoDot:1
+2 IF $DATA(APCLCMSS)
SET S=$PIECE($GET(^ACM(41,APCLCMSV,"DT")),U)
IF S=""
QUIT
IF '$DATA(APCLCMSS(S))
QUIT
+3 SET APCLVIEN=$PIECE(^ACM(41,APCLCMSV,0),U,2)
+4 DO PROC
+5 QUIT
End DoDot:1
+6 QUIT
END ;
+1 SET APCLET=$HOROLOG
+2 QUIT
V1 ;
+1 SET APCLVIEN=""
FOR
SET APCLVIEN=$ORDER(^AUPNVSIT("B",APCLODAT,APCLVIEN))
IF APCLVIEN'=+APCLVIEN
QUIT
IF $DATA(^AUPNVSIT(APCLVIEN,0))
IF $PIECE(^(0),U,9)
IF '$PIECE(^(0),U,11)
IF '$$DEMO^APCLUTL($PIECE(^AUPNVSIT(APCLVIEN,0),U,5),$GET(APCLDEMO))
DO PROC
+2 QUIT
PROC ;
+1 KILL APCLSPEC
+2 IF APCLPTVS="V"
SET APCLVREC=^AUPNVSIT(APCLVIEN,0)
SET DFN=$PIECE(APCLVREC,U,5)
+3 IF APCLPTVS="P"
SET DFN=APCLVIEN
+4 IF '$DATA(^DPT(DFN,0))
QUIT
+5 IF '$DATA(^AUPNPAT(DFN,0))
QUIT
+6 IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
QUIT
+7 DO SCREENS
+8 IF $DATA(APCLSKIP)
QUIT
+9 KILL APCLSRT,APCLPRNT
SET APCLCRIT=APCLSORT
SET APCLX=0
+10 IF $DATA(^APCLVSTS(APCLSORT,4))
XECUTE ^APCLVSTS(APCLSORT,4)
IF '$DATA(APCLPRNT)
Begin DoDot:1
+11 IF APCLPTVS="V"
SET Y=$PIECE($PIECE(APCLVREC,U),".")
SET APCLPRNT=Y
QUIT
+12 SET APCLPRNT=$PIECE(^DPT(DFN,0),U)
+13 QUIT
End DoDot:1
+14 SET APCLSRT=APCLPRNT
+15 DO SUBPAT
+16 SET ^XTMP("APCLVL",APCLJOB,APCLBTH,"DATA HITS",APCLSRT,APCLVIEN)=""
SET APCLRCNT=APCLRCNT+1
+17 IF $DATA(^XTMP("APCLVL",APCLJOB,APCLBTH,"PATIENTS",DFN))
QUIT
+18 SET ^XTMP("APCLVL",APCLJOB,APCLBTH,"PATIENTS",DFN)=""
SET APCLPTCT=APCLPTCT+1
+19 QUIT
SUBPAT ;tally # of patients by sort value on detailed/subtotal
+1 IF APCLCTYP="C"
QUIT
+2 IF APCLCTYP="P"
QUIT
+3 IF APCLCTYP="F"
QUIT
+4 IF APCLCTYP="T"
QUIT
+5 IF APCLCTYP="L"
QUIT
+6 IF $GET(APCLSRT)=""
SET APCLSRT="????"
+7 IF $DATA(^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PATIENT HIT",APCLSRT,DFN))
QUIT
+8 IF '$DATA(^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRT))
SET ^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRT)=0
+9 SET ^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRT)=^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRT)+1
+10 IF $DATA(^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PATIENT HIT",APCLSRT,DFN))
QUIT
+11 SET ^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PATIENT HIT",APCLSRT,DFN)=""
+12 QUIT
SCREENS ;
+1 KILL APCLSKIP
+2 SET APCLI=0
FOR
SET APCLI=$ORDER(^APCLVRPT(APCLRPT,11,APCLI))
IF APCLI'=+APCLI!($DATA(APCLSKIP))
QUIT
Begin DoDot:1
+3 IF '$PIECE(^APCLVSTS(APCLI,0),U,8)
DO SINGLE
QUIT
+4 DO MULT
+5 QUIT
End DoDot:1
+6 QUIT
SINGLE ;
+1 KILL X,APCLSPEC
SET X=""
SET APCLX=0
+2 IF $DATA(^APCLVSTS(APCLI,1))
XECUTE ^(1)
+3 IF X=""
SET APCLSKIP=""
QUIT
+4 IF '$DATA(APCLSPEC)
IF '$DATA(^APCLVRPT(APCLRPT,11,APCLI,11,"B",X))
SET APCLSKIP=""
QUIT
+5 QUIT
MULT ;
+1 KILL APCLFOUN,APCLSKIP,APCLSPEC,X
SET APCLX=0
SET X=""
+2 IF $DATA(^APCLVSTS(APCLI,1))
XECUTE ^(1)
+3 IF $ORDER(X(""))=""
SET APCLSKIP=""
QUIT
+4 IF '$DATA(APCLSPEC)
SET Y=""
FOR
SET Y=$ORDER(X(Y))
IF Y=""
QUIT
IF $DATA(^APCLVRPT(APCLRPT,11,APCLI,11,"B",Y))
SET APCLFOUN=""
QUIT
+5 IF $DATA(APCLSPEC)
IF $GET(X)
SET APCLFOUN=1
QUIT
+6 IF '$DATA(APCLFOUN)
SET APCLSKIP=""
+7 QUIT
XIT ;EP - CALLED FROM APCLVL
+1 KILL APCLBD,APCLBDD,APCLED,APCLEDD,APCLSD,APCLSORT,APCLSORV,APCLTCW,APCLRPT,APCLLHDR,APCLDISP,%H,APCLET,APCLLINE,APCLPRNM,APCLPRNT,APCLSKIP,APCLTYPE,APCLSPAG,APCLEN1,APCLSEAT,APCLPTVS,APCL,APCLCAND,APCLHDR,APCLHEAD,APCLSPEC,APCLOPT
+2 KILL APCLCTYP,APCLFLG,APCLG,APCLNAME,APCLNIFN,APCLSAVE,APCLTITL,APCLQUIT,APCLPCNT,APCLQFLG,APCLPTCT,APCLTL,APCLSRTR,APCLSRTV,APCLFILE,APCLJD,APCLFCNT,APCLX1,APCLX2,APCLSDAT
+3 KILL C,D,D0,DA,DIC,DD,DFN,DIADD,DLAYGO,DICR,DIE,DIK,DINUM,DIQ,DIR,DIRUT,DUOUT,DTOUT,DR,J,I,J,K,M,S,TS,X,Y,DIG,DIH,DIV,DQ,DDH,AMQQEN3,AMQQLX
XIT1 ;EP
+1 KILL APCLANS,APCLBTH,APCLC,APCLCNT,APCLCRIT,APCLCUT,APCLD,APCLDISP,APCLDONE,APCLHIGH,APCLI,APCLJOB,APCLQMAN,APCLSEL,APCLTEXT,APCLVAR,APCLSKIP,APCLPRNT,APCLPRNM,APCLLINE,APCLRCNT,APCLSCNT,APCLDFET,APCLY,DFN
+2 KILL X,X1,X2,IO("Q"),%,Y,POP,DIRUT,H,S,TS,M,DUOUT,DIR,DTOUT,V,Z,I,DIC,DIK,DIADD,DLAYGO,DA,DR,DIE,DIU,AMQQTAX,DINUM,APCLPACK,APCLEP1,APCLEP2,D,APCLLENG,APCLLHDR,APCLSAVE,AMQQND
+3 QUIT
