- YS142FIX ;SLC/KCM - Patch 142 fix scores with extra scales ; 03/20/2017
- ;;5.01;MENTAL HEALTH;**142**;Dec 30, 1994;Build 14
- ;
- ADM2019 ; loop through administrations from 2019
- N YS142S,YS142T,YS142D,YS142A,YS142U ; scales,test,date,admin,updates
- D BLDSCL
- S ^XTMP("YTS-RESCORE",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"MH Extraneous Scores"
- S YS142U=0
- S YS142T=0 F S YS142T=$O(^YTT(601.84,"AC",YS142T)) Q:'YS142T D
- . S YS142D=3190000 F S YS142D=$O(^YTT(601.84,"AC",YS142T,YS142D)) Q:'YS142D D
- . . S YS142A=0 F S YS142A=$O(^YTT(601.84,"AC",YS142T,YS142D,YS142A)) Q:'YS142A D
- . . . I $$SCALERR(YS142A) D RESCORE(YS142A)
- S ^XTMP("YTS-RESCORE","SCALE-UPDATES")=YS142U
- Q
- RESCORE(YS142A) ; delete results and rescore admin
- ; expects YS142U (update count)
- D DELRSLTS^YTSCOREV(YS142A)
- S $P(^YTT(601.84,YS142A,0),U,12)=0 ; force re-score to current revision
- I $$SCOREONE^YTSCOREV(YS142A) S YS142U=YS142U+1
- Q
- SCALERR(YS142A) ; return 1 if more scale scores than expected
- N TEST,CNT,RSLT,IEN
- S TEST=$P($G(^YTT(601.84,YS142A,0)),U,3)
- I '$G(YS142S(TEST),0) QUIT 0
- ;
- S CNT=0,RSLT=0
- S IEN=0 F S IEN=$O(^YTT(601.92,"AC",YS142A,IEN)) Q:'IEN D Q:RSLT
- . S CNT=CNT+1
- . I CNT>YS142S(TEST) S RSLT=1
- Q RSLT
- ;
- BLDSCL ; Build scales into YS142S
- ; builds array of scale counts per instrument
- N TEST,SCLCNT,GSEQ,GRP,SSEQ,SCL
- S TEST=0 F S TEST=$O(^YTT(601.71,TEST)) Q:'TEST D
- . I $P($G(^YTT(601.71,TEST,2)),U,2)'="Y" QUIT ; is active instrument?
- . S SCLCNT=0
- . S GSEQ=0 F S GSEQ=$O(^YTT(601.86,"AC",TEST,GSEQ)) Q:'GSEQ D
- . . S GRP=0 F S GRP=$O(^YTT(601.86,"AC",TEST,GSEQ,GRP)) Q:'GRP D
- . . . S SSEQ=0 F S SSEQ=$O(^YTT(601.87,"AC",GRP,SSEQ)) Q:'SSEQ D
- . . . . S SCL=0 F S SCL=$O(^YTT(601.87,"AC",GRP,SSEQ,SCL)) Q:'SCL D
- . . . . . S SCLCNT=SCLCNT+1
- . S YS142S(TEST)=SCLCNT ;_U_$P(^YTT(601.71,TEST,0),U)
- Q
- QTASK(RESUME) ; Create background task for checking extraneous scales
- N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTSK
- S ZTIO=""
- S ZTRTN="ADM2019^YS142FIX"
- S ZTDESC="Check extraneous MH scales"
- S ZTDTH=RESUME
- D ^%ZTLOAD
- I '$G(ZTSK) D MES^XPDUTL("Unsuccessful queue of re-scoring job.")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYS142FIX 2160 printed Mar 13, 2025@21:17:06 Page 2
- YS142FIX ;SLC/KCM - Patch 142 fix scores with extra scales ; 03/20/2017
- +1 ;;5.01;MENTAL HEALTH;**142**;Dec 30, 1994;Build 14
- +2 ;
- ADM2019 ; loop through administrations from 2019
- +1 ; scales,test,date,admin,updates
- NEW YS142S,YS142T,YS142D,YS142A,YS142U
- +2 DO BLDSCL
- +3 SET ^XTMP("YTS-RESCORE",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"MH Extraneous Scores"
- +4 SET YS142U=0
- +5 SET YS142T=0
- FOR
- SET YS142T=$ORDER(^YTT(601.84,"AC",YS142T))
- if 'YS142T
- QUIT
- Begin DoDot:1
- +6 SET YS142D=3190000
- FOR
- SET YS142D=$ORDER(^YTT(601.84,"AC",YS142T,YS142D))
- if 'YS142D
- QUIT
- Begin DoDot:2
- +7 SET YS142A=0
- FOR
- SET YS142A=$ORDER(^YTT(601.84,"AC",YS142T,YS142D,YS142A))
- if 'YS142A
- QUIT
- Begin DoDot:3
- +8 IF $$SCALERR(YS142A)
- DO RESCORE(YS142A)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +9 SET ^XTMP("YTS-RESCORE","SCALE-UPDATES")=YS142U
- +10 QUIT
- RESCORE(YS142A) ; delete results and rescore admin
- +1 ; expects YS142U (update count)
- +2 DO DELRSLTS^YTSCOREV(YS142A)
- +3 ; force re-score to current revision
- SET $PIECE(^YTT(601.84,YS142A,0),U,12)=0
- +4 IF $$SCOREONE^YTSCOREV(YS142A)
- SET YS142U=YS142U+1
- +5 QUIT
- SCALERR(YS142A) ; return 1 if more scale scores than expected
- +1 NEW TEST,CNT,RSLT,IEN
- +2 SET TEST=$PIECE($GET(^YTT(601.84,YS142A,0)),U,3)
- +3 IF '$GET(YS142S(TEST),0)
- QUIT 0
- +4 ;
- +5 SET CNT=0
- SET RSLT=0
- +6 SET IEN=0
- FOR
- SET IEN=$ORDER(^YTT(601.92,"AC",YS142A,IEN))
- if 'IEN
- QUIT
- Begin DoDot:1
- +7 SET CNT=CNT+1
- +8 IF CNT>YS142S(TEST)
- SET RSLT=1
- End DoDot:1
- if RSLT
- QUIT
- +9 QUIT RSLT
- +10 ;
- BLDSCL ; Build scales into YS142S
- +1 ; builds array of scale counts per instrument
- +2 NEW TEST,SCLCNT,GSEQ,GRP,SSEQ,SCL
- +3 SET TEST=0
- FOR
- SET TEST=$ORDER(^YTT(601.71,TEST))
- if 'TEST
- QUIT
- Begin DoDot:1
- +4 ; is active instrument?
- IF $PIECE($GET(^YTT(601.71,TEST,2)),U,2)'="Y"
- QUIT
- +5 SET SCLCNT=0
- +6 SET GSEQ=0
- FOR
- SET GSEQ=$ORDER(^YTT(601.86,"AC",TEST,GSEQ))
- if 'GSEQ
- QUIT
- Begin DoDot:2
- +7 SET GRP=0
- FOR
- SET GRP=$ORDER(^YTT(601.86,"AC",TEST,GSEQ,GRP))
- if 'GRP
- QUIT
- Begin DoDot:3
- +8 SET SSEQ=0
- FOR
- SET SSEQ=$ORDER(^YTT(601.87,"AC",GRP,SSEQ))
- if 'SSEQ
- QUIT
- Begin DoDot:4
- +9 SET SCL=0
- FOR
- SET SCL=$ORDER(^YTT(601.87,"AC",GRP,SSEQ,SCL))
- if 'SCL
- QUIT
- Begin DoDot:5
- +10 SET SCLCNT=SCLCNT+1
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +11 ;_U_$P(^YTT(601.71,TEST,0),U)
- SET YS142S(TEST)=SCLCNT
- End DoDot:1
- +12 QUIT
- QTASK(RESUME) ; Create background task for checking extraneous scales
- +1 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTSK
- +2 SET ZTIO=""
- +3 SET ZTRTN="ADM2019^YS142FIX"
- +4 SET ZTDESC="Check extraneous MH scales"
- +5 SET ZTDTH=RESUME
- +6 DO ^%ZTLOAD
- +7 IF '$GET(ZTSK)
- DO MES^XPDUTL("Unsuccessful queue of re-scoring job.")
- +8 QUIT
