source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFSS.m@ 862

Last change on this file since 862 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.2 KB
RevLine 
[613]1IBDFSS ;ALB/MAF - STATUS SELECT ROUTINE (FORMS TRACKING) ; 11-JUL-1995
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**16**;APR 24, 1997
3 ;
4 ;
5START ; -- Ask status to be displayed
6 D FULL^VALM1
7 K IBSTAT
8 S DIR("A")="Select ENCOUNTER FORM STATUS: ",DIR("B")="ALL"
9 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"
10 S DIR("?")="Enter desired status that you would like to have listed on the report"
11 D ^DIR
12 I $D(DTOUT)!$D(DUOUT) Q
13 I Y="A" D K DIR Q
14 .F X=0,1,2,3,4,5,6,7,11,12,20 S IBSTAT(X)=""
15 .S IBDFALL=1
16 D SET
17 S $P(DIR(0),"^",1)=$P(DIR(0),"^",1)_"O",$P(DIR(0),"^",2)=$E($P(DIR(0),"^",2),7,999) K DIR("B")
18 S DIR("A")="Select another STATUS: "
19ASK D ^DIR I $D(DUOUT)!$D(DTOUT) Q
20 I X]"" D SET G ASK
21 K DIR Q
22 ;
23 ;
24SET 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)
25 S IBSTAT(X)=""
26 Q
27 ;
28 ;
29EN ; -- main entry point for IBDF FT STATUS SELECT
30 D EN^VALM("IBDF FT STATUS SELECT")
31 Q
32 ;
33 ;
34SETARR ; -- Set up Listman array
35 S IBDCNT1=IBDCNT1+1
36 S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
37 S X=""
38 S IBDFVAL=$J(IBDCNT1_")",5)
39 S X=$$SETSTR^VALM1(IBDFVAL,X,1,5)
40 S IBDFVAL=$P($G(IBDFTMP),"^",2)
41 S X=$$SETSTR^VALM1(IBDFVAL,X,7,8)
42 S IBDFVAL=$P($G(IBDFTMP),"^",4) I IBDFVAL S IBDFVAL=$$FMTE^XLFDT(IBDFVAL,2)
43 S X=$$SETSTR^VALM1(IBDFVAL,X,17,14)
44 I $D(VAUTC)!($D(VAUTG)) S IBDFVAL=$P($G(IBDFTMP),"^",3) I IBDFVAL]"" S IBDFVAL=$P(^DPT(IBDFVAL,0),"^",1)
45 I $D(VAUTN) S IBDFVAL=$P($G(IBDFTMP),"^",1) I IBDFVAL]"" S IBDFVAL=$P(^SC(IBDFVAL,0),"^",1)
46 S X=$$SETSTR^VALM1(IBDFVAL,X,34,15)
47 S IBDFVAL=$P($G(IBDFTMP),"^",6) I IBDFVAL]"" S IBDFVAL=$E(IBDFVAL,4,5)_"/"_$E(IBDFVAL,6,7)_"/"_$E(IBDFVAL,2,3)
48 S X=$$SETSTR^VALM1(IBDFVAL,X,50,10)
49 S IBDFVAL=$P($G(IBDFTMP),"^",7) I IBDFVAL]"" S IBDFVAL=$E(IBDFVAL,4,5)_"/"_$E(IBDFVAL,6,7)_"/"_$E(IBDFVAL,2,3)
50 S X=$$SETSTR^VALM1(IBDFVAL,X,62,10)
51 S IBDFVAL=$P($G(IBDFTMP),"^",12)
52 I IBDFVAL']""&($D(STATUS)) S IBDFVAL=$S(STATUS="":"AVL DE",STATUS["N":"NO SHOW","C^NA^CA^PC^PCA^"[STATUS:"CANCELED",1:"AVL DE")
53 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)
54 S X=$$SETSTR^VALM1(IBDFVAL,X,74,6)
55 ;
56 ;
57TMP ; -- Set up TMP Array
58 S ^TMP("SSEL",$J,IBDCNT,0)=$$LOWER^VALM1(X),^TMP("SSEL",$J,"IDX",VALMCNT,IBDCNT1)=""
59 S ^TMP("SELIDX",$J,IBDCNT1)=VALMCNT_"^"_$P(IBDFTMP,"^",2)_"^"_$P(IBDFTMP,"^",3)_"^"_$P(IBDFTMP,"^",4)_"^"_$P(IBDFTMP,"^",6)_"^"_$P(IBDFTMP,"^",7)_"^"_$P(IBDFTMP,"^",12)
60 Q
61 ;
62 ;
63HDR ; -- header code
64 S IBDFX=$P($$FMTE^XLFDT(IBDFBG),"@")
65 S IBDFY=$P($$FMTE^XLFDT(IBDFEND),"@")
66 S VALMHDR(1)="Encounter forms with selected status for the date range of "
67 S VALMHDR(2)=IBDFX_" to "_IBDFY
68 Q
69 ;
70 ;
71INIT ; -- init variables and list array
72 N IBDCNT,IBDCNT1,IBDFDV,IBDFCL,IBDFTMP,IBDFPT,IBDFPAT,IBDFT,STATUS
73 S (IBDFDV,IBDFCL,IBDCNT,IBDCNT1,IBDFPT,VALMCNT)=0
74 K ^TMP("SSEL",$J),^TMP("SELIDX",$J)
75 I $D(VAUTG) D
76 .N IBDFGR
77 .S IBDFGR=0
78 .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
79 ..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
80 ...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
81 ....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
82 ....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
83 I '$D(VAUTG) D
84 .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
85 ..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
86 ...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
87 ....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
88 ....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
89 I '$D(^TMP("SSEL",$J)) D NUL
90 Q
91 ;
92 ;
93NUL ; -- NULL MESSAGE
94 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
95 Q
96 ;
97 ;
98HELP ; -- help code
99 S X="?" D DISP^XQORM1 W !!
100 Q
101 ;
102 ;
103EXIT ; -- exit code
104 K ^TMP("SSEL",$J),^TMP("SELIDX",$J),IBSTAT,IBCLIN,IBDFDIV1,DIR,IBDFSTAT,IBDFX,IBDFY,IBDFALL
105 Q
106 ;
107 ;
108EXPND ; -- expand code
109 Q
110 ;
Note: See TracBrowser for help on using the repository browser.