IBDFSS ;ALB/MAF - STATUS SELECT ROUTINE (FORMS TRACKING) ; 11-JUL-1995
;;3.0;AUTOMATED INFO COLLECTION SYS;**16**;APR 24, 1997
;
;
START ; -- Ask status to be displayed
D FULL^VALM1
K IBSTAT
S DIR("A")="Select ENCOUNTER FORM STATUS: ",DIR("B")="ALL"
S DIR(0)="SA^A:ALL;1:PRINTED;2:SCANNED;3:SCANNED TO PCE;4:SCANNED W/PCE ERROR;5:DATA ENTRY;6:DATA ENTRY TO PCE;7:DATA ENTRY W/PCE ERROR;11:PENDING PAGES;12:ERROR DETECTED, NOT TRANSMITTED;20:AVAILABLE FOR DATA ENTRY"
S DIR("?")="Enter desired status that you would like to have listed on the report"
D ^DIR
I $D(DTOUT)!$D(DUOUT) Q
I Y="A" D K DIR Q
.F X=0,1,2,3,4,5,6,7,11,12,20 S IBSTAT(X)=""
.S IBDFALL=1
D SET
S $P(DIR(0),"^",1)=$P(DIR(0),"^",1)_"O",$P(DIR(0),"^",2)=$E($P(DIR(0),"^",2),7,999) K DIR("B")
S DIR("A")="Select another STATUS: "
ASK D ^DIR I $D(DUOUT)!$D(DTOUT) Q
I X]"" D SET G ASK
K DIR Q
;
;
SET S X=$S(Y=1:1,Y=2:2,Y=3:3,Y=4:4,Y=5:5,Y=6:6,Y=7:7,Y=11:11,Y=12:12,Y=20:20,1:0)
S IBSTAT(X)=""
Q
;
;
EN ; -- main entry point for IBDF FT STATUS SELECT
D EN^VALM("IBDF FT STATUS SELECT")
Q
;
;
SETARR ; -- Set up Listman array
S IBDCNT1=IBDCNT1+1
S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S X=""
S IBDFVAL=$J(IBDCNT1_")",5)
S X=$$SETSTR^VALM1(IBDFVAL,X,1,5)
S IBDFVAL=$P($G(IBDFTMP),"^",2)
S X=$$SETSTR^VALM1(IBDFVAL,X,7,8)
S IBDFVAL=$P($G(IBDFTMP),"^",4) I IBDFVAL S IBDFVAL=$$FMTE^XLFDT(IBDFVAL,2)
S X=$$SETSTR^VALM1(IBDFVAL,X,17,14)
I $D(VAUTC)!($D(VAUTG)) S IBDFVAL=$P($G(IBDFTMP),"^",3) I IBDFVAL]"" S IBDFVAL=$P(^DPT(IBDFVAL,0),"^",1)
I $D(VAUTN) S IBDFVAL=$P($G(IBDFTMP),"^",1) I IBDFVAL]"" S IBDFVAL=$P(^SC(IBDFVAL,0),"^",1)
S X=$$SETSTR^VALM1(IBDFVAL,X,34,15)
S IBDFVAL=$P($G(IBDFTMP),"^",6) I IBDFVAL]"" S IBDFVAL=$E(IBDFVAL,4,5)_"/"_$E(IBDFVAL,6,7)_"/"_$E(IBDFVAL,2,3)
S X=$$SETSTR^VALM1(IBDFVAL,X,50,10)
S IBDFVAL=$P($G(IBDFTMP),"^",7) I IBDFVAL]"" S IBDFVAL=$E(IBDFVAL,4,5)_"/"_$E(IBDFVAL,6,7)_"/"_$E(IBDFVAL,2,3)
S X=$$SETSTR^VALM1(IBDFVAL,X,62,10)
S IBDFVAL=$P($G(IBDFTMP),"^",12)
I IBDFVAL']""&($D(STATUS)) S IBDFVAL=$S(STATUS="":"AVL DE",STATUS["N":"NO SHOW","C^NA^CA^PC^PCA^"[STATUS:"CANCELED",1:"AVL DE")
S IBDFVAL=$S(IBDFVAL=1:"PRINTD",IBDFVAL=2:"SCANND",IBDFVAL=3:"SC/PCE",IBDFVAL=4:"SC/ER",IBDFVAL=5:"DENTRY",IBDFVAL=6:"DE/PCE",IBDFVAL=7:"DE/ER",IBDFVAL=11:"PENDNG",IBDFVAL=12:"ER/NTR",IBDFVAL=20:"AVL DE",1:IBDFVAL)
S X=$$SETSTR^VALM1(IBDFVAL,X,74,6)
;
;
TMP ; -- Set up TMP Array
S ^TMP("SSEL",$J,IBDCNT,0)=$$LOWER^VALM1(X),^TMP("SSEL",$J,"IDX",VALMCNT,IBDCNT1)=""
S ^TMP("SELIDX",$J,IBDCNT1)=VALMCNT_"^"_$P(IBDFTMP,"^",2)_"^"_$P(IBDFTMP,"^",3)_"^"_$P(IBDFTMP,"^",4)_"^"_$P(IBDFTMP,"^",6)_"^"_$P(IBDFTMP,"^",7)_"^"_$P(IBDFTMP,"^",12)
Q
;
;
HDR ; -- header code
S IBDFX=$P($$FMTE^XLFDT(IBDFBG),"@")
S IBDFY=$P($$FMTE^XLFDT(IBDFEND),"@")
S VALMHDR(1)="Encounter forms with selected status for the date range of "
S VALMHDR(2)=IBDFX_" to "_IBDFY
Q
;
;
INIT ; -- init variables and list array
N IBDCNT,IBDCNT1,IBDFDV,IBDFCL,IBDFTMP,IBDFPT,IBDFPAT,IBDFT,STATUS
S (IBDFDV,IBDFCL,IBDCNT,IBDCNT1,IBDFPT,VALMCNT)=0
K ^TMP("SSEL",$J),^TMP("SELIDX",$J)
I $D(VAUTG) D
.N IBDFGR
.S IBDFGR=0
.F IBDFDIV=0:0 S IBDFDV=$O(^TMP("FTRK",$J,IBDFDV)) Q:IBDFDV']"" F IBDFGRO=0:0 S IBDFGR=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR)) Q:IBDFGR']"" F IBDFCLI=0:0 S IBDFCL=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR,IBDFCL)) Q:IBDFCL']"" D
..F IBDFT=0:0 S IBDFT=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR,IBDFCL,IBDFT)) Q:'IBDFT F IBDFPAT=0:0 S IBDFPT=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR,IBDFCL,IBDFT,IBDFPT)) Q:IBDFPT']"" D
...F IBDFIFN=0:0 S IBDFIFN=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR,IBDFCL,IBDFT,IBDFPT,IBDFIFN)) Q:'IBDFIFN S IBDX="" F S IBDX=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR,IBDFCL,IBDFT,IBDFPT,IBDFIFN,IBDX)) Q:IBDX="" S IBDFTMP=^(IBDX) D
....S STATUS=$P($G(^DPT(+$G(IBDFIFN),"S",+$G(IBDFT),0)),"^",2) I '$D(IBDFALL),STATUS]"" I "^N^C^NA^CA^PC^PCA^"[STATUS Q
....S IBDFSTAT=$P(IBDFTMP,"^",12) I $D(IBSTAT(+IBDFSTAT))!($D(IBSTAT(20))&(IBDFSTAT="")) D:'$D(IBDFDIV1(IBDFDV)) HEADER^IBDFSS1 D:'$D(IBDFGRP1(IBDFDV,IBDFGR)) HEADER2^IBDFSS1 D:'$D(IBCLIN(IBDFGR,IBDFCL)) HEADER1^IBDFSS1 D SETARR
I '$D(VAUTG) D
.F IBDFDIV=0:0 S IBDFDV=$O(^TMP("FTRK",$J,IBDFDV)) Q:IBDFDV']"" F IBDFCLI=0:0 S IBDFCL=$O(^TMP("FTRK",$J,IBDFDV,IBDFCL)) Q:IBDFCL']"" D
..F IBDFT=0:0 S IBDFT=$O(^TMP("FTRK",$J,IBDFDV,IBDFCL,IBDFT)) Q:'IBDFT F IBDFPAT=0:0 S IBDFPT=$O(^TMP("FTRK",$J,IBDFDV,IBDFCL,IBDFT,IBDFPT)) Q:IBDFPT']"" D
...F IBDFIFN=0:0 S IBDFIFN=$O(^TMP("FTRK",$J,IBDFDV,IBDFCL,IBDFT,IBDFPT,IBDFIFN)) Q:'IBDFIFN S IBDX="" F S IBDX=$O(^TMP("FTRK",$J,IBDFDV,IBDFCL,IBDFT,IBDFPT,IBDFIFN,IBDX)) Q:IBDX="" S IBDFTMP=^(IBDX) D
....S STATUS=$P($G(^DPT(+$G(IBDFIFN),"S",+$G(IBDFT),0)),"^",2) I '$D(IBDFALL),STATUS]"" I "^N^C^NA^CA^PC^PCA^"[STATUS Q
....S IBDFSTAT=$P(IBDFTMP,"^",12) I $D(IBSTAT(+IBDFSTAT))!($D(IBSTAT(20))&(IBDFSTAT="")) D:'$D(IBDFDIV1(IBDFDV)) HEADER^IBDFSS1 D:'$D(IBCLIN(IBDFDV,IBDFCL)) HEADER1^IBDFSS1 D SETARR
I '$D(^TMP("SSEL",$J)) D NUL
Q
;
;
NUL ; -- NULL MESSAGE
S ^TMP("SSEL",$J,1,0)=" ",^TMP("SSEL",$J,2,0)="There are no encounter forms that meet this criteria.",^TMP("SELIDX",$J,1)=1,^TMP("SELIDX",$J,2)=2
Q
;
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
;
EXIT ; -- exit code
K ^TMP("SSEL",$J),^TMP("SELIDX",$J),IBSTAT,IBCLIN,IBDFDIV1,DIR,IBDFSTAT,IBDFX,IBDFY,IBDFALL
Q
;
;
EXPND ; -- expand code
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFSS 5449 printed Dec 13, 2024@02:53:25 Page 2
IBDFSS ;ALB/MAF - STATUS SELECT ROUTINE (FORMS TRACKING) ; 11-JUL-1995
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**16**;APR 24, 1997
+2 ;
+3 ;
START ; -- Ask status to be displayed
+1 DO FULL^VALM1
+2 KILL IBSTAT
+3 SET DIR("A")="Select ENCOUNTER FORM STATUS: "
SET DIR("B")="ALL"
+4 SET DIR(0)="SA^A:ALL;1:PRINTED;2:SCANNED;3:SCANNED TO PCE;4:SCANNED W/PCE ERROR;5:DATA ENTRY;6:DATA ENTRY TO PCE;7:DATA ENTRY W/PCE ERROR;11:PENDING PAGES;12:ERROR DETECTED, NOT TRANSMITTED;20:AVAILABLE FOR DATA ENTRY"
+5 SET DIR("?")="Enter desired status that you would like to have listed on the report"
+6 DO ^DIR
+7 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+8 IF Y="A"
Begin DoDot:1
+9 FOR X=0,1,2,3,4,5,6,7,11,12,20
SET IBSTAT(X)=""
+10 SET IBDFALL=1
End DoDot:1
KILL DIR
QUIT
+11 DO SET
+12 SET $PIECE(DIR(0),"^",1)=$PIECE(DIR(0),"^",1)_"O"
SET $PIECE(DIR(0),"^",2)=$EXTRACT($PIECE(DIR(0),"^",2),7,999)
KILL DIR("B")
+13 SET DIR("A")="Select another STATUS: "
ASK DO ^DIR
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+1 IF X]""
DO SET
GOTO ASK
+2 KILL DIR
QUIT
+3 ;
+4 ;
SET SET X=$SELECT(Y=1:1,Y=2:2,Y=3:3,Y=4:4,Y=5:5,Y=6:6,Y=7:7,Y=11:11,Y=12:12,Y=20:20,1:0)
+1 SET IBSTAT(X)=""
+2 QUIT
+3 ;
+4 ;
EN ; -- main entry point for IBDF FT STATUS SELECT
+1 DO EN^VALM("IBDF FT STATUS SELECT")
+2 QUIT
+3 ;
+4 ;
SETARR ; -- Set up Listman array
+1 SET IBDCNT1=IBDCNT1+1
+2 SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+3 SET X=""
+4 SET IBDFVAL=$JUSTIFY(IBDCNT1_")",5)
+5 SET X=$$SETSTR^VALM1(IBDFVAL,X,1,5)
+6 SET IBDFVAL=$PIECE($GET(IBDFTMP),"^",2)
+7 SET X=$$SETSTR^VALM1(IBDFVAL,X,7,8)
+8 SET IBDFVAL=$PIECE($GET(IBDFTMP),"^",4)
IF IBDFVAL
SET IBDFVAL=$$FMTE^XLFDT(IBDFVAL,2)
+9 SET X=$$SETSTR^VALM1(IBDFVAL,X,17,14)
+10 IF $DATA(VAUTC)!($DATA(VAUTG))
SET IBDFVAL=$PIECE($GET(IBDFTMP),"^",3)
IF IBDFVAL]""
SET IBDFVAL=$PIECE(^DPT(IBDFVAL,0),"^",1)
+11 IF $DATA(VAUTN)
SET IBDFVAL=$PIECE($GET(IBDFTMP),"^",1)
IF IBDFVAL]""
SET IBDFVAL=$PIECE(^SC(IBDFVAL,0),"^",1)
+12 SET X=$$SETSTR^VALM1(IBDFVAL,X,34,15)
+13 SET IBDFVAL=$PIECE($GET(IBDFTMP),"^",6)
IF IBDFVAL]""
SET IBDFVAL=$EXTRACT(IBDFVAL,4,5)_"/"_$EXTRACT(IBDFVAL,6,7)_"/"_$EXTRACT(IBDFVAL,2,3)
+14 SET X=$$SETSTR^VALM1(IBDFVAL,X,50,10)
+15 SET IBDFVAL=$PIECE($GET(IBDFTMP),"^",7)
IF IBDFVAL]""
SET IBDFVAL=$EXTRACT(IBDFVAL,4,5)_"/"_$EXTRACT(IBDFVAL,6,7)_"/"_$EXTRACT(IBDFVAL,2,3)
+16 SET X=$$SETSTR^VALM1(IBDFVAL,X,62,10)
+17 SET IBDFVAL=$PIECE($GET(IBDFTMP),"^",12)
+18 IF IBDFVAL']""&($DATA(STATUS))
SET IBDFVAL=$SELECT(STATUS="":"AVL DE",STATUS["N":"NO SHOW","C^NA^CA^PC^PCA^"[STATUS:"CANCELED",1:"AVL DE")
+19 SET IBDFVAL=$SELECT(IBDFVAL=1:"PRINTD",IBDFVAL=2:"SCANND",IBDFVAL=3:"SC/PCE",IBDFVAL=4:"SC/ER",IBDFVAL=5:"DENTRY",IBDFVAL=6:"DE/PCE",IBDFVAL=7:"DE/ER",IBDFVAL=11:"PENDNG",IBDFVAL=12:"ER/NTR",IBDFVAL=20:"AVL DE",1:IBDFVAL)
+20 SET X=$$SETSTR^VALM1(IBDFVAL,X,74,6)
+21 ;
+22 ;
TMP ; -- Set up TMP Array
+1 SET ^TMP("SSEL",$JOB,IBDCNT,0)=$$LOWER^VALM1(X)
SET ^TMP("SSEL",$JOB,"IDX",VALMCNT,IBDCNT1)=""
+2 SET ^TMP("SELIDX",$JOB,IBDCNT1)=VALMCNT_"^"_$PIECE(IBDFTMP,"^",2)_"^"_$PIECE(IBDFTMP,"^",3)_"^"_$PIECE(IBDFTMP,"^",4)_"^"_$PIECE(IBDFTMP,"^",6)_"^"_$PIECE(IBDFTMP,"^",7)_"^"_$PIECE(IBDFTMP,"^",12)
+3 QUIT
+4 ;
+5 ;
HDR ; -- header code
+1 SET IBDFX=$PIECE($$FMTE^XLFDT(IBDFBG),"@")
+2 SET IBDFY=$PIECE($$FMTE^XLFDT(IBDFEND),"@")
+3 SET VALMHDR(1)="Encounter forms with selected status for the date range of "
+4 SET VALMHDR(2)=IBDFX_" to "_IBDFY
+5 QUIT
+6 ;
+7 ;
INIT ; -- init variables and list array
+1 NEW IBDCNT,IBDCNT1,IBDFDV,IBDFCL,IBDFTMP,IBDFPT,IBDFPAT,IBDFT,STATUS
+2 SET (IBDFDV,IBDFCL,IBDCNT,IBDCNT1,IBDFPT,VALMCNT)=0
+3 KILL ^TMP("SSEL",$JOB),^TMP("SELIDX",$JOB)
+4 IF $DATA(VAUTG)
Begin DoDot:1
+5 NEW IBDFGR
+6 SET IBDFGR=0
+7 FOR IBDFDIV=0:0
SET IBDFDV=$ORDER(^TMP("FTRK",$JOB,IBDFDV))
if IBDFDV']""
QUIT
FOR IBDFGRO=0:0
SET IBDFGR=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFGR))
if IBDFGR']""
QUIT
FOR IBDFCLI=0:0
SET IBDFCL=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFGR,IBDFCL))
if IBDFCL']""
QUIT
Begin DoDot:2
+8 FOR IBDFT=0:0
SET IBDFT=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFGR,IBDFCL,IBDFT))
if 'IBDFT
QUIT
FOR IBDFPAT=0:0
SET IBDFPT=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFGR,IBDFCL,IBDFT,IBDFPT))
if IBDFPT']""
QUIT
Begin DoDot:3
+9 FOR IBDFIFN=0:0
SET IBDFIFN=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFGR,IBDFCL,IBDFT,IBDFPT,IBDFIFN))
if 'IBDFIFN
QUIT
SET IBDX=""
FOR
SET IBDX=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFGR,IBDFCL,IBDFT,IBDFPT,IBDFIFN,IBDX))
if IBDX=""
QUIT
SET IBDFTMP=^(IBDX)
Begin DoDot:4
+10 SET STATUS=$PIECE($GET(^DPT(+$GET(IBDFIFN),"S",+$GET(IBDFT),0)),"^",2)
IF '$DATA(IBDFALL)
IF STATUS]""
IF "^N^C^NA^CA^PC^PCA^"[STATUS
QUIT
+11 SET IBDFSTAT=$PIECE(IBDFTMP,"^",12)
IF $DATA(IBSTAT(+IBDFSTAT))!($DATA(IBSTAT(20))&(IBDFSTAT=""))
if '$DATA(IBDFDIV1(IBDFDV))
DO HEADER^IBDFSS1
if '$DATA(IBDFGRP1(IBDFDV,IBDFGR))
DO HEADER2^IBDFSS1
if '$DATA(IBCLIN(IBDFGR,IBDFCL))
DO HEADER1^IBDFSS1
DO SETARR
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+12 IF '$DATA(VAUTG)
Begin DoDot:1
+13 FOR IBDFDIV=0:0
SET IBDFDV=$ORDER(^TMP("FTRK",$JOB,IBDFDV))
if IBDFDV']""
QUIT
FOR IBDFCLI=0:0
SET IBDFCL=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFCL))
if IBDFCL']""
QUIT
Begin DoDot:2
+14 FOR IBDFT=0:0
SET IBDFT=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFCL,IBDFT))
if 'IBDFT
QUIT
FOR IBDFPAT=0:0
SET IBDFPT=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFCL,IBDFT,IBDFPT))
if IBDFPT']""
QUIT
Begin DoDot:3
+15 FOR IBDFIFN=0:0
SET IBDFIFN=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFCL,IBDFT,IBDFPT,IBDFIFN))
if 'IBDFIFN
QUIT
SET IBDX=""
FOR
SET IBDX=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFCL,IBDFT,IBDFPT,IBDFIFN,IBDX))
if IBDX=""
QUIT
SET IBDFTMP=^(IBDX)
Begin DoDot:4
+16 SET STATUS=$PIECE($GET(^DPT(+$GET(IBDFIFN),"S",+$GET(IBDFT),0)),"^",2)
IF '$DATA(IBDFALL)
IF STATUS]""
IF "^N^C^NA^CA^PC^PCA^"[STATUS
QUIT
+17 SET IBDFSTAT=$PIECE(IBDFTMP,"^",12)
IF $DATA(IBSTAT(+IBDFSTAT))!($DATA(IBSTAT(20))&(IBDFSTAT=""))
if '$DATA(IBDFDIV1(IBDFDV))
DO HEADER^IBDFSS1
if '$DATA(IBCLIN(IBDFDV,IBDFCL))
DO HEADER1^IBDFSS1
DO SETARR
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+18 IF '$DATA(^TMP("SSEL",$JOB))
DO NUL
+19 QUIT
+20 ;
+21 ;
NUL ; -- NULL MESSAGE
+1 SET ^TMP("SSEL",$JOB,1,0)=" "
SET ^TMP("SSEL",$JOB,2,0)="There are no encounter forms that meet this criteria."
SET ^TMP("SELIDX",$JOB,1)=1
SET ^TMP("SELIDX",$JOB,2)=2
+2 QUIT
+3 ;
+4 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
+4 ;
EXIT ; -- exit code
+1 KILL ^TMP("SSEL",$JOB),^TMP("SELIDX",$JOB),IBSTAT,IBCLIN,IBDFDIV1,DIR,IBDFSTAT,IBDFX,IBDFY,IBDFALL
+2 QUIT
+3 ;
+4 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
