source: WorldVistAEHR/trunk/r/NURSING_SERVICE-NUR/NURQUTL.m@ 623

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

initial load of WorldVistAEHR
File size: 4.7 KB
Line 
1NURQUTL ;HIRMFO/RM-QI SUMMARY UTILITIES ;4/24/96
2 ;;4.0;NURSING SERVICE;;Apr 25, 1997
3PERFORM(NURQSURV,NURQLOC) ; This function will do a lookup on the
4 ; Performance measure multiple and return a valid entry, or -1.
5 ; Input variables: NURQSURV=IEN in file 217
6 ; NURQLOC=IEN in 217.04 sub-file (Location)
7 ; Return Value: IEN in 217.43 sub-file, or -1 if none selected.
8 ; NURQOUT=1 if user abnormally terminated selection.
9 ;
10 N NURQFXN S NURQFXN=-1
11 K ^TMP($J,"NURQPMS"),^TMP($J,"NURQPMA")
12 D GETPM(","_NURQLOC_","_NURQSURV_",")
13 S %=$P($G(^SC(+$P($G(^NURQ(217,NURQSURV,2,NURQLOC,0)),"^"),0)),"^"),NURQPLOC=$S(%?1"NUR ".E:$P(%,"NUR ",2),1:%)
14REPM ; Label is here so can jump back to reask Performance Measures.
15 W !!!,"The following performance measures have been selected for "_NURQPLOC_":"
16 D LISTQUES("^TMP($J,""NURQPMS"",") G QPM:NURQOUT
17 S Y=$O(^TMP($J,"NURQPMS",9999999),-1) S:$G(NURQDA)>0 Y=""
18 W !,"Select PERFORMANCE MEASURE: "_$S(Y]"":Y_"// ",1:"") R X:DTIME
19 S:'$T X="^^" S:X=""&$L(Y) X=Y I X="^"!(X="^^") S NURQOUT=1
20 I "^^"'[X D G QPM:NURQOUT,REPM:NURQFXN<0
21 . S NURQX=X,NURQY=Y
22 . S NURQFXN=$P($G(^TMP($J,"NURQPMS",NURQX)),"^",2) Q:NURQFXN>0
23 . S NURQFXN=-1 D:'$D(^TMP($J,"NURQPMA")) GETQUES(","_NURQSURV_",")
24 . S NURQFXN=$P($G(^TMP($J,"NURQPMA",NURQX)),"^",2) Q:NURQFXN>0
25 . S NURQFXN=-1 I NURQX'?1"?".E W !,$C(7),"INVALID ENTRY"
26 . W !," Choose from: "
27 . D LISTQUES("^TMP($J,""NURQPMA"",")
28 . Q
29QPM ; Quit and exit PERFORM procedure
30 K NURQPLOC,NURQX,NURQY,^TMP($J,"NURQPMA"),^TMP($J,"NURQPMS")
31 Q NURQFXN
32LISTQUES(ARRAY) ; This procedure will list perfmance measures selected so far,
33 ; or questions that can be selected. ARRAY will be set to the list
34 ; of performance measures to print.
35 N NURQQNO,NURQQUES,NURQTXT,NURQX
36 W # S NURQQNO=0 F S NURQQNO=$O(@(ARRAY_NURQQNO_")")) Q:NURQQNO'>0 D
37 . S NURQSEQ=+$G(@(ARRAY_NURQQNO_")")) Q:NURQSEQ=""
38 . S NURQX=0 F S NURQX=$O(@(ARRAY_"""WRITE"","_NURQSEQ_","_NURQX_")")) Q:NURQX'>0 D
39 . . S NURQTXT=$G(@(ARRAY_"""WRITE"","_NURQSEQ_","_NURQX_")"))
40 . . W !,NURQTXT
41 . . I $Y>(IOSL-3) S DIR(0)="E" D ^DIR S:Y NURQOUT=1
42 . . Q
43 . Q
44 Q
45GETQUES(NURQIENS) ; This procedure will get the Questions from 748.26
46 ; sub-file for the entry defined by NURQIENS (FM DB IENS format).
47 ; Data will be returned in the ^TMP($J,"NURQPMA", array.
48 K ^TMP("DILIST",$J),^TMP($J,"NURQSEQ")
49 D LIST^DIC(748.26,NURQIENS,"","","","","","","","D QUESID^NURQUTL(Y1)")
50 K ^TMP($J,"NURQPMA") M ^TMP($J,"NURQPMA")=^TMP($J,"NURQSEQ")
51 M ^TMP($J,"NURQPMA","WRITE")=^TMP("DILIST",$J,"ID","WRITE")
52 M ^TMP($J,"NURQPMA","DA")=^TMP($J,"DILIST",$J,2)
53 K ^TMP("DILIST",$J),^TMP($J,"NURQSEQ")
54 Q
55GETPM(NURQIENS) ; This procedure will get the Performance Measures from 217.43
56 ; sub-file for the entry defined by NURQIENS (FM DB IENS format).
57 ; Data will be returned in the ^TMP($J,"NURQPMS", array.
58 ;
59 K ^TMP("DILIST",$J),^TMP($J,"NURQSEQ")
60 D LIST^DIC(217.43,","_NURQLOC_","_NURQSURV_",","","","","","","","","D PMID^NURQUTL")
61 K ^TMP($J,"NURQPMS") M ^TMP($J,"NURQPMS")=^TMP($J,"NURQSEQ")
62 M ^TMP($J,"NURQPMS","WRITE")=^TMP("DILIST",$J,"ID","WRITE")
63 M ^TMP($J,"NURQPMS","DA")=^TMP("DILIST",$J,2)
64 K ^TMP("DILIST",$J),^TMP($J,"NURQSEQ")
65 Q
66PMID ; This procedure is called by Identifier code in LIST^DIC call which
67 ; is returning the printable text for the question to be listed for
68 ; a particular entry in the Performance Measure (217.43) sub-file.
69 ;
70 N NURQIENS,NURQREF
71 S NURQREF=$P(^(0),"^")
72 S NURQIENS=$P(NURQREF,",",4)_","_$P(NURQREF,",",2)_","
73 D QUESID(NURQIENS)
74 Q
75QUESID(NURQIENS) ; This procedure is given the entry in the Question
76 ; (748.26) sub-file defined by NURQIENS (in DBS IENS format), will
77 ; set the printable text of that question for a LIST^DIC call.
78 ;
79 N NURQSURV,NURQQUES,NURQDAT,NURQQNO,NURQSEQ,NURQX,NURQY
80 D GETS^DIQ(748.26,NURQIENS,".015;.05","","NURQDAT")
81 S NURQQNO=$G(NURQDAT(748.26,NURQIENS,.015)) Q:NURQQNO=""
82 S NURQSEQ=$O(^TMP("DILIST",$J,1,""),-1) Q:NURQSEQ=""
83 S ^TMP($J,"NURQSEQ",NURQQNO)=NURQSEQ_"^"_$P(NURQIENS,",")
84 S NURQ1ST=1 K ^UTILITY($J,"W")
85 I $O(NURQDAT(748.26,NURQIENS,.05,0)) D
86 . S NURQX=0 F S NURQX=$O(NURQDAT(748.26,NURQIENS,.05,NURQX)) Q:NURQX'>0 S X=$G(NURQDAT(748.26,NURQIENS,.05,NURQX)) I $G(X)]"" D
87 . . I NURQ1ST S X=$J(NURQQNO,3)_" "_X
88 . . E S %=$G(^UTILITY($J,"W",8)),X=$G(^UTILITY($J,"W",8,%,0))_X K ^UTILITY($J,"W",8,%,0) S ^UTILITY($J,"W",8)=%-1
89 . . S DIWL=8,DIWR=IOM-2,DIWF="" D ^DIWP K DIWL,DIWR,DIWF S NURQ1ST=0
90 . . Q
91 . Q
92 E D
93 . S X=NURQQNO
94 . S DIWL=8,DIWR=IOM-2,DIWF="" D ^DIWP K DIWL,DIWR,DIWF
95 . Q
96 S NURQX=0 F S NURQX=$O(^UTILITY($J,"W",8,NURQX)) Q:NURQX'>0 D
97 . S NURQY=$G(^UTILITY($J,"W",8,NURQX,0))
98 . I NURQY]"" D EN^DDIOL(NURQY,"",$S(NURQX=1:"!?0",1:"!?7"))
99 . Q
100 K ^UTILITY($J,"W")
101 Q
Note: See TracBrowser for help on using the repository browser.