NURQUTL ;HIRMFO/RM-QI SUMMARY UTILITIES ;4/24/96
;;4.0;NURSING SERVICE;;Apr 25, 1997
PERFORM(NURQSURV,NURQLOC) ; This function will do a lookup on the
; Performance measure multiple and return a valid entry, or -1.
; Input variables: NURQSURV=IEN in file 217
; NURQLOC=IEN in 217.04 sub-file (Location)
; Return Value: IEN in 217.43 sub-file, or -1 if none selected.
; NURQOUT=1 if user abnormally terminated selection.
;
N NURQFXN S NURQFXN=-1
K ^TMP($J,"NURQPMS"),^TMP($J,"NURQPMA")
D GETPM(","_NURQLOC_","_NURQSURV_",")
S %=$P($G(^SC(+$P($G(^NURQ(217,NURQSURV,2,NURQLOC,0)),"^"),0)),"^"),NURQPLOC=$S(%?1"NUR ".E:$P(%,"NUR ",2),1:%)
REPM ; Label is here so can jump back to reask Performance Measures.
W !!!,"The following performance measures have been selected for "_NURQPLOC_":"
D LISTQUES("^TMP($J,""NURQPMS"",") G QPM:NURQOUT
S Y=$O(^TMP($J,"NURQPMS",9999999),-1) S:$G(NURQDA)>0 Y=""
W !,"Select PERFORMANCE MEASURE: "_$S(Y]"":Y_"// ",1:"") R X:DTIME
S:'$T X="^^" S:X=""&$L(Y) X=Y I X="^"!(X="^^") S NURQOUT=1
I "^^"'[X D G QPM:NURQOUT,REPM:NURQFXN<0
. S NURQX=X,NURQY=Y
. S NURQFXN=$P($G(^TMP($J,"NURQPMS",NURQX)),"^",2) Q:NURQFXN>0
. S NURQFXN=-1 D:'$D(^TMP($J,"NURQPMA")) GETQUES(","_NURQSURV_",")
. S NURQFXN=$P($G(^TMP($J,"NURQPMA",NURQX)),"^",2) Q:NURQFXN>0
. S NURQFXN=-1 I NURQX'?1"?".E W !,$C(7),"INVALID ENTRY"
. W !," Choose from: "
. D LISTQUES("^TMP($J,""NURQPMA"",")
. Q
QPM ; Quit and exit PERFORM procedure
K NURQPLOC,NURQX,NURQY,^TMP($J,"NURQPMA"),^TMP($J,"NURQPMS")
Q NURQFXN
LISTQUES(ARRAY) ; This procedure will list perfmance measures selected so far,
; or questions that can be selected. ARRAY will be set to the list
; of performance measures to print.
N NURQQNO,NURQQUES,NURQTXT,NURQX
W # S NURQQNO=0 F S NURQQNO=$O(@(ARRAY_NURQQNO_")")) Q:NURQQNO'>0 D
. S NURQSEQ=+$G(@(ARRAY_NURQQNO_")")) Q:NURQSEQ=""
. S NURQX=0 F S NURQX=$O(@(ARRAY_"""WRITE"","_NURQSEQ_","_NURQX_")")) Q:NURQX'>0 D
. . S NURQTXT=$G(@(ARRAY_"""WRITE"","_NURQSEQ_","_NURQX_")"))
. . W !,NURQTXT
. . I $Y>(IOSL-3) S DIR(0)="E" D ^DIR S:Y NURQOUT=1
. . Q
. Q
Q
GETQUES(NURQIENS) ; This procedure will get the Questions from 748.26
; sub-file for the entry defined by NURQIENS (FM DB IENS format).
; Data will be returned in the ^TMP($J,"NURQPMA", array.
K ^TMP("DILIST",$J),^TMP($J,"NURQSEQ")
D LIST^DIC(748.26,NURQIENS,"","","","","","","","D QUESID^NURQUTL(Y1)")
K ^TMP($J,"NURQPMA") M ^TMP($J,"NURQPMA")=^TMP($J,"NURQSEQ")
M ^TMP($J,"NURQPMA","WRITE")=^TMP("DILIST",$J,"ID","WRITE")
M ^TMP($J,"NURQPMA","DA")=^TMP($J,"DILIST",$J,2)
K ^TMP("DILIST",$J),^TMP($J,"NURQSEQ")
Q
GETPM(NURQIENS) ; This procedure will get the Performance Measures from 217.43
; sub-file for the entry defined by NURQIENS (FM DB IENS format).
; Data will be returned in the ^TMP($J,"NURQPMS", array.
;
K ^TMP("DILIST",$J),^TMP($J,"NURQSEQ")
D LIST^DIC(217.43,","_NURQLOC_","_NURQSURV_",","","","","","","","","D PMID^NURQUTL")
K ^TMP($J,"NURQPMS") M ^TMP($J,"NURQPMS")=^TMP($J,"NURQSEQ")
M ^TMP($J,"NURQPMS","WRITE")=^TMP("DILIST",$J,"ID","WRITE")
M ^TMP($J,"NURQPMS","DA")=^TMP("DILIST",$J,2)
K ^TMP("DILIST",$J),^TMP($J,"NURQSEQ")
Q
PMID ; This procedure is called by Identifier code in LIST^DIC call which
; is returning the printable text for the question to be listed for
; a particular entry in the Performance Measure (217.43) sub-file.
;
N NURQIENS,NURQREF
S NURQREF=$P(^(0),"^")
S NURQIENS=$P(NURQREF,",",4)_","_$P(NURQREF,",",2)_","
D QUESID(NURQIENS)
Q
QUESID(NURQIENS) ; This procedure is given the entry in the Question
; (748.26) sub-file defined by NURQIENS (in DBS IENS format), will
; set the printable text of that question for a LIST^DIC call.
;
N NURQSURV,NURQQUES,NURQDAT,NURQQNO,NURQSEQ,NURQX,NURQY
D GETS^DIQ(748.26,NURQIENS,".015;.05","","NURQDAT")
S NURQQNO=$G(NURQDAT(748.26,NURQIENS,.015)) Q:NURQQNO=""
S NURQSEQ=$O(^TMP("DILIST",$J,1,""),-1) Q:NURQSEQ=""
S ^TMP($J,"NURQSEQ",NURQQNO)=NURQSEQ_"^"_$P(NURQIENS,",")
S NURQ1ST=1 K ^UTILITY($J,"W")
I $O(NURQDAT(748.26,NURQIENS,.05,0)) D
. 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
. . I NURQ1ST S X=$J(NURQQNO,3)_" "_X
. . 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
. . S DIWL=8,DIWR=IOM-2,DIWF="" D ^DIWP K DIWL,DIWR,DIWF S NURQ1ST=0
. . Q
. Q
E D
. S X=NURQQNO
. S DIWL=8,DIWR=IOM-2,DIWF="" D ^DIWP K DIWL,DIWR,DIWF
. Q
S NURQX=0 F S NURQX=$O(^UTILITY($J,"W",8,NURQX)) Q:NURQX'>0 D
. S NURQY=$G(^UTILITY($J,"W",8,NURQX,0))
. I NURQY]"" D EN^DDIOL(NURQY,"",$S(NURQX=1:"!?0",1:"!?7"))
. Q
K ^UTILITY($J,"W")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURQUTL 4904 printed Nov 22, 2024@17:31:18 Page 2
NURQUTL ;HIRMFO/RM-QI SUMMARY UTILITIES ;4/24/96
+1 ;;4.0;NURSING SERVICE;;Apr 25, 1997
PERFORM(NURQSURV,NURQLOC) ; This function will do a lookup on the
+1 ; Performance measure multiple and return a valid entry, or -1.
+2 ; Input variables: NURQSURV=IEN in file 217
+3 ; NURQLOC=IEN in 217.04 sub-file (Location)
+4 ; Return Value: IEN in 217.43 sub-file, or -1 if none selected.
+5 ; NURQOUT=1 if user abnormally terminated selection.
+6 ;
+7 NEW NURQFXN
SET NURQFXN=-1
+8 KILL ^TMP($JOB,"NURQPMS"),^TMP($JOB,"NURQPMA")
+9 DO GETPM(","_NURQLOC_","_NURQSURV_",")
+10 SET %=$PIECE($GET(^SC(+$PIECE($GET(^NURQ(217,NURQSURV,2,NURQLOC,0)),"^"),0)),"^")
SET NURQPLOC=$SELECT(%?1"NUR ".E:$PIECE(%,"NUR ",2),1:%)
REPM ; Label is here so can jump back to reask Performance Measures.
+1 WRITE !!!,"The following performance measures have been selected for "_NURQPLOC_":"
+2 DO LISTQUES("^TMP($J,""NURQPMS"",")
if NURQOUT
GOTO QPM
+3 SET Y=$ORDER(^TMP($JOB,"NURQPMS",9999999),-1)
if $GET(NURQDA)>0
SET Y=""
+4 WRITE !,"Select PERFORMANCE MEASURE: "_$SELECT(Y]"":Y_"// ",1:"")
READ X:DTIME
+5 if '$TEST
SET X="^^"
if X=""&$LENGTH(Y)
SET X=Y
IF X="^"!(X="^^")
SET NURQOUT=1
+6 IF "^^"'[X
Begin DoDot:1
+7 SET NURQX=X
SET NURQY=Y
+8 SET NURQFXN=$PIECE($GET(^TMP($JOB,"NURQPMS",NURQX)),"^",2)
if NURQFXN>0
QUIT
+9 SET NURQFXN=-1
if '$DATA(^TMP($JOB,"NURQPMA"))
DO GETQUES(","_NURQSURV_",")
+10 SET NURQFXN=$PIECE($GET(^TMP($JOB,"NURQPMA",NURQX)),"^",2)
if NURQFXN>0
QUIT
+11 SET NURQFXN=-1
IF NURQX'?1"?".E
WRITE !,$CHAR(7),"INVALID ENTRY"
+12 WRITE !," Choose from: "
+13 DO LISTQUES("^TMP($J,""NURQPMA"",")
+14 QUIT
End DoDot:1
if NURQOUT
GOTO QPM
if NURQFXN<0
GOTO REPM
QPM ; Quit and exit PERFORM procedure
+1 KILL NURQPLOC,NURQX,NURQY,^TMP($JOB,"NURQPMA"),^TMP($JOB,"NURQPMS")
+2 QUIT NURQFXN
LISTQUES(ARRAY) ; This procedure will list perfmance measures selected so far,
+1 ; or questions that can be selected. ARRAY will be set to the list
+2 ; of performance measures to print.
+3 NEW NURQQNO,NURQQUES,NURQTXT,NURQX
+4 WRITE #
SET NURQQNO=0
FOR
SET NURQQNO=$ORDER(@(ARRAY_NURQQNO_")"))
if NURQQNO'>0
QUIT
Begin DoDot:1
+5 SET NURQSEQ=+$GET(@(ARRAY_NURQQNO_")"))
if NURQSEQ=""
QUIT
+6 SET NURQX=0
FOR
SET NURQX=$ORDER(@(ARRAY_"""WRITE"","_NURQSEQ_","_NURQX_")"))
if NURQX'>0
QUIT
Begin DoDot:2
+7 SET NURQTXT=$GET(@(ARRAY_"""WRITE"","_NURQSEQ_","_NURQX_")"))
+8 WRITE !,NURQTXT
+9 IF $Y>(IOSL-3)
SET DIR(0)="E"
DO ^DIR
if Y
SET NURQOUT=1
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
GETQUES(NURQIENS) ; This procedure will get the Questions from 748.26
+1 ; sub-file for the entry defined by NURQIENS (FM DB IENS format).
+2 ; Data will be returned in the ^TMP($J,"NURQPMA", array.
+3 KILL ^TMP("DILIST",$JOB),^TMP($JOB,"NURQSEQ")
+4 DO LIST^DIC(748.26,NURQIENS,"","","","","","","","D QUESID^NURQUTL(Y1)")
+5 KILL ^TMP($JOB,"NURQPMA")
MERGE ^TMP($JOB,"NURQPMA")=^TMP($JOB,"NURQSEQ")
+6 MERGE ^TMP($JOB,"NURQPMA","WRITE")=^TMP("DILIST",$JOB,"ID","WRITE")
+7 MERGE ^TMP($JOB,"NURQPMA","DA")=^TMP($JOB,"DILIST",$JOB,2)
+8 KILL ^TMP("DILIST",$JOB),^TMP($JOB,"NURQSEQ")
+9 QUIT
GETPM(NURQIENS) ; This procedure will get the Performance Measures from 217.43
+1 ; sub-file for the entry defined by NURQIENS (FM DB IENS format).
+2 ; Data will be returned in the ^TMP($J,"NURQPMS", array.
+3 ;
+4 KILL ^TMP("DILIST",$JOB),^TMP($JOB,"NURQSEQ")
+5 DO LIST^DIC(217.43,","_NURQLOC_","_NURQSURV_",","","","","","","","","D PMID^NURQUTL")
+6 KILL ^TMP($JOB,"NURQPMS")
MERGE ^TMP($JOB,"NURQPMS")=^TMP($JOB,"NURQSEQ")
+7 MERGE ^TMP($JOB,"NURQPMS","WRITE")=^TMP("DILIST",$JOB,"ID","WRITE")
+8 MERGE ^TMP($JOB,"NURQPMS","DA")=^TMP("DILIST",$JOB,2)
+9 KILL ^TMP("DILIST",$JOB),^TMP($JOB,"NURQSEQ")
+10 QUIT
PMID ; This procedure is called by Identifier code in LIST^DIC call which
+1 ; is returning the printable text for the question to be listed for
+2 ; a particular entry in the Performance Measure (217.43) sub-file.
+3 ;
+4 NEW NURQIENS,NURQREF
+5 SET NURQREF=$PIECE(^(0),"^")
+6 SET NURQIENS=$PIECE(NURQREF,",",4)_","_$PIECE(NURQREF,",",2)_","
+7 DO QUESID(NURQIENS)
+8 QUIT
QUESID(NURQIENS) ; This procedure is given the entry in the Question
+1 ; (748.26) sub-file defined by NURQIENS (in DBS IENS format), will
+2 ; set the printable text of that question for a LIST^DIC call.
+3 ;
+4 NEW NURQSURV,NURQQUES,NURQDAT,NURQQNO,NURQSEQ,NURQX,NURQY
+5 DO GETS^DIQ(748.26,NURQIENS,".015;.05","","NURQDAT")
+6 SET NURQQNO=$GET(NURQDAT(748.26,NURQIENS,.015))
if NURQQNO=""
QUIT
+7 SET NURQSEQ=$ORDER(^TMP("DILIST",$JOB,1,""),-1)
if NURQSEQ=""
QUIT
+8 SET ^TMP($JOB,"NURQSEQ",NURQQNO)=NURQSEQ_"^"_$PIECE(NURQIENS,",")
+9 SET NURQ1ST=1
KILL ^UTILITY($JOB,"W")
+10 IF $ORDER(NURQDAT(748.26,NURQIENS,.05,0))
Begin DoDot:1
+11 SET NURQX=0
FOR
SET NURQX=$ORDER(NURQDAT(748.26,NURQIENS,.05,NURQX))
if NURQX'>0
QUIT
SET X=$GET(NURQDAT(748.26,NURQIENS,.05,NURQX))
IF $GET(X)]""
Begin DoDot:2
+12 IF NURQ1ST
SET X=$JUSTIFY(NURQQNO,3)_" "_X
+13 IF '$TEST
SET %=$GET(^UTILITY($JOB,"W",8))
SET X=$GET(^UTILITY($JOB,"W",8,%,0))_X
KILL ^UTILITY($JOB,"W",8,%,0)
SET ^UTILITY($JOB,"W",8)=%-1
+14 SET DIWL=8
SET DIWR=IOM-2
SET DIWF=""
DO ^DIWP
KILL DIWL,DIWR,DIWF
SET NURQ1ST=0
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 IF '$TEST
Begin DoDot:1
+18 SET X=NURQQNO
+19 SET DIWL=8
SET DIWR=IOM-2
SET DIWF=""
DO ^DIWP
KILL DIWL,DIWR,DIWF
+20 QUIT
End DoDot:1
+21 SET NURQX=0
FOR
SET NURQX=$ORDER(^UTILITY($JOB,"W",8,NURQX))
if NURQX'>0
QUIT
Begin DoDot:1
+22 SET NURQY=$GET(^UTILITY($JOB,"W",8,NURQX,0))
+23 IF NURQY]""
DO EN^DDIOL(NURQY,"",$SELECT(NURQX=1:"!?0",1:"!?7"))
+24 QUIT
End DoDot:1
+25 KILL ^UTILITY($JOB,"W")
+26 QUIT
