- 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
- 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
