- 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 Jan 18, 2025@03:54:36 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 ;