YTXCHGV ;SLC/KCM - Instrument Specification Validation ; 9/15/2015
;;5.01;MENTAL HEALTH;**121**;Dec 30, 1994;Build 61
;
IDXALL ; Index all tests
N TEST,CNT,XCHGIDX
S CNT=1,XCHGIDX=1 ; XCHGIDX is flag to build full index
D LOG^YTXCHGU("info","Gathering installed instruments")
L +^XTMP("YTXIDX"):60 E Q
K ^XTMP("YTXIDX")
S ^XTMP("YTXIDX",0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"MH Instrument Combined Index"
S TEST=0 F S TEST=$O(^YTT(601.71,TEST)) Q:'TEST D
. S CNT=CNT+1
. W:'(CNT#10) "."
. D BLDTEST(TEST)
L -^XTMP("YTXIDX")
Q
ADDIDX(FILE,IEN,TEST) ; add entry to full index
N XCHGIDX S XCHGIDX=1
L +^XTMP("YTXIDX",FILE):DILOCKTM E Q
D SETP(FILE,IEN)
L -^XTMP("YTXIDX",FILE)
Q
DELIDX(FILE,IEN,TEST) ; remove entry from full index
L +^XTMP("YTXIDX",FILE):DILOCKTM E Q
K ^XTMP("YTXIDX",FILE,IEN,TEST)
L -^XTMP("YTXIDX",FILE)
Q
COLLIDE(FILE,IEN) ; return 1 if there is a collision with another instrument
; expects TSTIEN to be the IEN of the current instrument
I '$G(TSTIEN) Q 0 ; no test to compare with
I $D(^XTMP("YTXIDX","ignore",FILE,IEN)) Q 0 ; ignore collision
N I,X
S X=""
S I=0 F S I=$O(^XTMP("YTXIDX",FILE,IEN,I)) Q:'I I I'=TSTIEN D
. S X=X_$S($L(X):",",1:"")_$P(^YTT(601.71,I,0),U)
I $L(X) D LOG^YTXCHGU("conflict",FILE_":"_IEN_" used by "_X)
Q $S($L(X):1,1:0)
;
ISONLY(FILE,IEN,TSTIEN) ; return 1 if TEST is only user of FILE:IEN
N I,CNT
S CNT=0
S I=0 F S I=$O(^XTMP("YTXIDX",FILE,IEN,I)) Q:'I I I'=TSTIEN S CNT=CNT+1
Q:'CNT 1
Q 0
;
BLDTEST(TEST,GBLROOT) ; Assemble IEN's used by TEST
D SETP(601.71,TEST)
; MH INSTRUMENT CONTENT loop
N IC,XC0,IQ,XQ2,ICT,XCT,XCT0
S IC=0 F S IC=$O(^YTT(601.76,"AC",TEST,IC)) Q:'IC D
. S XC0=$G(^YTT(601.76,IC,0)),IQ=+$P(XC0,U,4)
. D SETP(601.76,IC) ; content entry
. D SETP(601.72,IQ) ; question entry
. D SETP(601.88,+$P(XC0,U,6)) ; question display
. D SETP(601.88,+$P(XC0,U,7)) ; intro display
. D SETP(601.88,+$P(XC0,U,8)) ; choice display
. S XQ2=$G(^YTT(601.72,IQ,2)),XCT=+$P(XQ2,U,3)
. D SETP(601.73,+$P(XQ2,U)) ; intro entry
. D SETP(601.89,+$O(^YTT(601.89,"B",XCT,0))) ; choice identifier entry
. S ICT=0 F S ICT=$O(^YTT(601.751,"B",XCT,ICT)) Q:'ICT D
. . D SETP(601.751,ICT) ; choicetype entry
. . S XCT0=$G(^YTT(601.751,ICT,0))
. . D SETP(601.75,+$P(XCT0,U,3)) ; choice entry
; MH SCALEGROUPS loop
N IG,XG0,IS,XS0,IK
S IG=0 F S IG=$O(^YTT(601.86,"AD",TEST,IG)) Q:'IG D
. S XG0=$G(^YTT(601.86,IG,0))
. D SETP(601.86,IG) ; scalegroup entry
. S IS=0 F S IS=$O(^YTT(601.87,"AD",IG,IS)) Q:'IS D
. . S XS0=$G(^YTT(601.87,IS,0))
. . D SETP(601.87,IS) ; scale entry
. . S IK=0 F S IK=$O(^YTT(601.91,"AC",IS,IK)) Q:'IK D
. . . D SETP(601.91,IK) ; scoring key entry
; MH SECTIONS loop
N I,X0
S I=0 F S I=$O(^YTT(601.81,"AC",TEST,I)) Q:'I D
. S X0=$G(^YTT(601.81,I,0))
. D SETP(601.81,I) ; section entry
. D SETP(601.72,+$P(X0,U,3)) ; question entry
. D SETP(601.88,+$P(X0,U,6)) ; section display
; MH INSTRUMENTRULES loop
S I=0 F S I=$O(^YTT(601.83,"C",TEST,I)) Q:'I D
. S X0=$G(^YTT(601.83,I,0))
. D SETP(601.83,I) ; instrumentrule entry
. D SETP(601.72,+$P(X0,U,3)) ; question entry
. D SETP(601.82,+$P(X0,U,4)) ; rule entry
; MH SKIPPED QUESTIONS loop
S I=0 F S I=$O(^YTT(601.79,"AC",TEST,I)) Q:'I D
. S X0=$G(^YTT(601.79,I,0))
. D SETP(601.79,I) ; skipped question entry
. D SETP(601.82,+$P(X0,U,3)) ; rule entry
. D SETP(601.72,+$P(X0,U,4)) ; question entry
Q
SETP(FILE,IEN) ; Set file,ien pair in global
; expects XCHGIDX (for cross-file index) or GBLROOT
Q:'IEN
Q:'$D(^YTT(FILE,IEN,0))
I $G(XCHGIDX) S ^XTMP("YTXIDX",FILE,IEN,TEST)="" QUIT
S @GBLROOT@(FILE,IEN)=""
Q
;
;
VERIFY(TREE,YTXERRS,YTXDELS) ; Verify no conflicts, find records to remove
; TREE: global reference for instruments being installed
; SEQ: identifies which instrument
; ERRORS: contains up to 6 instances of record conflicts
; DELETES: lists entries that may be deleted
;
N TEST,ENTRY,FILE,IEN,X
S TEST=@TREE@("info","name")
S TEST=$O(^YTT(601.71,"B",TEST,0))
Q:'TEST
K ^TMP($J,"local")
D BLDTEST(TEST)
;
; look for entries that locally might belong to another instrument
S ENTRY=0,YTXERRS=0
F S ENTRY=$O(@TREE@("verify",ENTRY)) Q:'ENTRY D Q:YTXERRS>5
. S X=@TREE@("verify",ENTRY),FILE=$P(X,":"),IEN=$P(X,":",2)
. I '$$CHKNODE(FILE,IEN) D
. . S YTXERRS=YTXERRS+1
. . S YTXERRS(YTXERRS)="Entry "_FILE_":"_IEN_" belongs to another test"
;
; look for local entries that should be deleted
S ENTRY=0,YTXDELS=0
F S ENTRY=$O(@TREE@("verify",ENTRY)) Q:'ENTRY D
. S X=@TREE@("verify",ENTRY),FILE=$P(X,":"),IEN=$P(X,":",2)
. K ^TMP($J,"local",FILE,IEN)
S FILE=0 F S FILE=$O(^TMP($J,"local",FILE)) Q:'FILE D
. S IEN=0 F S IEN=$O(^TMP($J,"local",FILE,IEN)) Q:'IEN D
. . S YTXDELS=YTXDELS+1
. . S YTXDELS(FILE,IEN)=""
;
K ^TMP($J,"local")
Q
CHKNODE(FILE,IEN) ; Check to see if node belongs to same test
I '$D(^YTT(FILE,IEN,0)) Q -1 ; not found, node will be added
I $D(^TMP($J,"local",FILE,IEN)) Q 1 ; same test, node may be updated
Q 0 ; node present, different test
;
BELONG(FILE,IEN) ; Return line of instruments this entry belongs to
N TEST,X
S X=""
S TEST=0 F S TEST=$O(^XTMP("YTXIDX",FILE,IEN,TEST)) Q:'TEST D
. S X=X_$S($L(X):",",1:"")_$P(^YTT(601.71,TEST,0),U)
Q X
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTXCHGV 5854 printed Apr 09, 2024@21:16:47 Page 2
YTXCHGV ;SLC/KCM - Instrument Specification Validation ; 9/15/2015
+1 ;;5.01;MENTAL HEALTH;**121**;Dec 30, 1994;Build 61
+2 ;
IDXALL ; Index all tests
+1 NEW TEST,CNT,XCHGIDX
+2 ; XCHGIDX is flag to build full index
SET CNT=1
SET XCHGIDX=1
+3 DO LOG^YTXCHGU("info","Gathering installed instruments")
+4 LOCK +^XTMP("YTXIDX"):60
IF '$TEST
QUIT
+5 KILL ^XTMP("YTXIDX")
+6 SET ^XTMP("YTXIDX",0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"MH Instrument Combined Index"
+7 SET TEST=0
FOR
SET TEST=$ORDER(^YTT(601.71,TEST))
if 'TEST
QUIT
Begin DoDot:1
+8 SET CNT=CNT+1
+9 if '(CNT#10)
WRITE "."
+10 DO BLDTEST(TEST)
End DoDot:1
+11 LOCK -^XTMP("YTXIDX")
+12 QUIT
ADDIDX(FILE,IEN,TEST) ; add entry to full index
+1 NEW XCHGIDX
SET XCHGIDX=1
+2 LOCK +^XTMP("YTXIDX",FILE):DILOCKTM
IF '$TEST
QUIT
+3 DO SETP(FILE,IEN)
+4 LOCK -^XTMP("YTXIDX",FILE)
+5 QUIT
DELIDX(FILE,IEN,TEST) ; remove entry from full index
+1 LOCK +^XTMP("YTXIDX",FILE):DILOCKTM
IF '$TEST
QUIT
+2 KILL ^XTMP("YTXIDX",FILE,IEN,TEST)
+3 LOCK -^XTMP("YTXIDX",FILE)
+4 QUIT
COLLIDE(FILE,IEN) ; return 1 if there is a collision with another instrument
+1 ; expects TSTIEN to be the IEN of the current instrument
+2 ; no test to compare with
IF '$GET(TSTIEN)
QUIT 0
+3 ; ignore collision
IF $DATA(^XTMP("YTXIDX","ignore",FILE,IEN))
QUIT 0
+4 NEW I,X
+5 SET X=""
+6 SET I=0
FOR
SET I=$ORDER(^XTMP("YTXIDX",FILE,IEN,I))
if 'I
QUIT
IF I'=TSTIEN
Begin DoDot:1
+7 SET X=X_$SELECT($LENGTH(X):",",1:"")_$PIECE(^YTT(601.71,I,0),U)
End DoDot:1
+8 IF $LENGTH(X)
DO LOG^YTXCHGU("conflict",FILE_":"_IEN_" used by "_X)
+9 QUIT $SELECT($LENGTH(X):1,1:0)
+10 ;
ISONLY(FILE,IEN,TSTIEN) ; return 1 if TEST is only user of FILE:IEN
+1 NEW I,CNT
+2 SET CNT=0
+3 SET I=0
FOR
SET I=$ORDER(^XTMP("YTXIDX",FILE,IEN,I))
if 'I
QUIT
IF I'=TSTIEN
SET CNT=CNT+1
+4 if 'CNT
QUIT 1
+5 QUIT 0
+6 ;
BLDTEST(TEST,GBLROOT) ; Assemble IEN's used by TEST
+1 DO SETP(601.71,TEST)
+2 ; MH INSTRUMENT CONTENT loop
+3 NEW IC,XC0,IQ,XQ2,ICT,XCT,XCT0
+4 SET IC=0
FOR
SET IC=$ORDER(^YTT(601.76,"AC",TEST,IC))
if 'IC
QUIT
Begin DoDot:1
+5 SET XC0=$GET(^YTT(601.76,IC,0))
SET IQ=+$PIECE(XC0,U,4)
+6 ; content entry
DO SETP(601.76,IC)
+7 ; question entry
DO SETP(601.72,IQ)
+8 ; question display
DO SETP(601.88,+$PIECE(XC0,U,6))
+9 ; intro display
DO SETP(601.88,+$PIECE(XC0,U,7))
+10 ; choice display
DO SETP(601.88,+$PIECE(XC0,U,8))
+11 SET XQ2=$GET(^YTT(601.72,IQ,2))
SET XCT=+$PIECE(XQ2,U,3)
+12 ; intro entry
DO SETP(601.73,+$PIECE(XQ2,U))
+13 ; choice identifier entry
DO SETP(601.89,+$ORDER(^YTT(601.89,"B",XCT,0)))
+14 SET ICT=0
FOR
SET ICT=$ORDER(^YTT(601.751,"B",XCT,ICT))
if 'ICT
QUIT
Begin DoDot:2
+15 ; choicetype entry
DO SETP(601.751,ICT)
+16 SET XCT0=$GET(^YTT(601.751,ICT,0))
+17 ; choice entry
DO SETP(601.75,+$PIECE(XCT0,U,3))
End DoDot:2
End DoDot:1
+18 ; MH SCALEGROUPS loop
+19 NEW IG,XG0,IS,XS0,IK
+20 SET IG=0
FOR
SET IG=$ORDER(^YTT(601.86,"AD",TEST,IG))
if 'IG
QUIT
Begin DoDot:1
+21 SET XG0=$GET(^YTT(601.86,IG,0))
+22 ; scalegroup entry
DO SETP(601.86,IG)
+23 SET IS=0
FOR
SET IS=$ORDER(^YTT(601.87,"AD",IG,IS))
if 'IS
QUIT
Begin DoDot:2
+24 SET XS0=$GET(^YTT(601.87,IS,0))
+25 ; scale entry
DO SETP(601.87,IS)
+26 SET IK=0
FOR
SET IK=$ORDER(^YTT(601.91,"AC",IS,IK))
if 'IK
QUIT
Begin DoDot:3
+27 ; scoring key entry
DO SETP(601.91,IK)
End DoDot:3
End DoDot:2
End DoDot:1
+28 ; MH SECTIONS loop
+29 NEW I,X0
+30 SET I=0
FOR
SET I=$ORDER(^YTT(601.81,"AC",TEST,I))
if 'I
QUIT
Begin DoDot:1
+31 SET X0=$GET(^YTT(601.81,I,0))
+32 ; section entry
DO SETP(601.81,I)
+33 ; question entry
DO SETP(601.72,+$PIECE(X0,U,3))
+34 ; section display
DO SETP(601.88,+$PIECE(X0,U,6))
End DoDot:1
+35 ; MH INSTRUMENTRULES loop
+36 SET I=0
FOR
SET I=$ORDER(^YTT(601.83,"C",TEST,I))
if 'I
QUIT
Begin DoDot:1
+37 SET X0=$GET(^YTT(601.83,I,0))
+38 ; instrumentrule entry
DO SETP(601.83,I)
+39 ; question entry
DO SETP(601.72,+$PIECE(X0,U,3))
+40 ; rule entry
DO SETP(601.82,+$PIECE(X0,U,4))
End DoDot:1
+41 ; MH SKIPPED QUESTIONS loop
+42 SET I=0
FOR
SET I=$ORDER(^YTT(601.79,"AC",TEST,I))
if 'I
QUIT
Begin DoDot:1
+43 SET X0=$GET(^YTT(601.79,I,0))
+44 ; skipped question entry
DO SETP(601.79,I)
+45 ; rule entry
DO SETP(601.82,+$PIECE(X0,U,3))
+46 ; question entry
DO SETP(601.72,+$PIECE(X0,U,4))
End DoDot:1
+47 QUIT
SETP(FILE,IEN) ; Set file,ien pair in global
+1 ; expects XCHGIDX (for cross-file index) or GBLROOT
+2 if 'IEN
QUIT
+3 if '$DATA(^YTT(FILE,IEN,0))
QUIT
+4 IF $GET(XCHGIDX)
SET ^XTMP("YTXIDX",FILE,IEN,TEST)=""
QUIT
+5 SET @GBLROOT@(FILE,IEN)=""
+6 QUIT
+7 ;
+8 ;
VERIFY(TREE,YTXERRS,YTXDELS) ; Verify no conflicts, find records to remove
+1 ; TREE: global reference for instruments being installed
+2 ; SEQ: identifies which instrument
+3 ; ERRORS: contains up to 6 instances of record conflicts
+4 ; DELETES: lists entries that may be deleted
+5 ;
+6 NEW TEST,ENTRY,FILE,IEN,X
+7 SET TEST=@TREE@("info","name")
+8 SET TEST=$ORDER(^YTT(601.71,"B",TEST,0))
+9 if 'TEST
QUIT
+10 KILL ^TMP($JOB,"local")
+11 DO BLDTEST(TEST)
+12 ;
+13 ; look for entries that locally might belong to another instrument
+14 SET ENTRY=0
SET YTXERRS=0
+15 FOR
SET ENTRY=$ORDER(@TREE@("verify",ENTRY))
if 'ENTRY
QUIT
Begin DoDot:1
+16 SET X=@TREE@("verify",ENTRY)
SET FILE=$PIECE(X,":")
SET IEN=$PIECE(X,":",2)
+17 IF '$$CHKNODE(FILE,IEN)
Begin DoDot:2
+18 SET YTXERRS=YTXERRS+1
+19 SET YTXERRS(YTXERRS)="Entry "_FILE_":"_IEN_" belongs to another test"
End DoDot:2
End DoDot:1
if YTXERRS>5
QUIT
+20 ;
+21 ; look for local entries that should be deleted
+22 SET ENTRY=0
SET YTXDELS=0
+23 FOR
SET ENTRY=$ORDER(@TREE@("verify",ENTRY))
if 'ENTRY
QUIT
Begin DoDot:1
+24 SET X=@TREE@("verify",ENTRY)
SET FILE=$PIECE(X,":")
SET IEN=$PIECE(X,":",2)
+25 KILL ^TMP($JOB,"local",FILE,IEN)
End DoDot:1
+26 SET FILE=0
FOR
SET FILE=$ORDER(^TMP($JOB,"local",FILE))
if 'FILE
QUIT
Begin DoDot:1
+27 SET IEN=0
FOR
SET IEN=$ORDER(^TMP($JOB,"local",FILE,IEN))
if 'IEN
QUIT
Begin DoDot:2
+28 SET YTXDELS=YTXDELS+1
+29 SET YTXDELS(FILE,IEN)=""
End DoDot:2
End DoDot:1
+30 ;
+31 KILL ^TMP($JOB,"local")
+32 QUIT
CHKNODE(FILE,IEN) ; Check to see if node belongs to same test
+1 ; not found, node will be added
IF '$DATA(^YTT(FILE,IEN,0))
QUIT -1
+2 ; same test, node may be updated
IF $DATA(^TMP($JOB,"local",FILE,IEN))
QUIT 1
+3 ; node present, different test
QUIT 0
+4 ;
BELONG(FILE,IEN) ; Return line of instruments this entry belongs to
+1 NEW TEST,X
+2 SET X=""
+3 SET TEST=0
FOR
SET TEST=$ORDER(^XTMP("YTXIDX",FILE,IEN,TEST))
if 'TEST
QUIT
Begin DoDot:1
+4 SET X=X_$SELECT($LENGTH(X):",",1:"")_$PIECE(^YTT(601.71,TEST,0),U)
End DoDot:1
+5 QUIT X
+6 ;
