- YTCHECK ;SLC/TGA-CHECK PSYCH TEST/INTERVIEW DATA BASE ; 7/10/89 11:21 ;03/11/94 12:13
- ;;5.01;MENTAL HEALTH;;Dec 30, 1994
- ;
- ; Called from the top by MENU option YSMCHK
- ;
- S ;
- W @IOF,?22,"Check Psych Test/Interview Data Base"
- W !!,"You may use this option for individual patients or all patients."
- W !,"If you use it for individual patients, you may elect to delete any unknown"
- W !,"tests/interviews and any tests/interviews with erroneous response sets."
- W !,"If you use it for all patients, you may elect to print a list of errors or"
- W !,"automatically delete all unknown patients, unknown instruments, and all"
- W !,"instruments with erroneous response sets."
- W !!,"THIS OPTION SHOULD NOT BE RUN WHILE TESTS/INTERVIEWS ARE UNDERWAY!",$C(7)
- 1 ;
- W !!,"Check (I)ndividual patient or (A)ll patients: I// " R A:DTIME S YSTOUT='$T,YSUOUT=A["^" G:YSTOUT!YSUOUT KIL S A=$TR($E(A),"ia","IA")
- I "AI"'[A W:A'["?" " ?",$C(7) W !,"Type 'I' to check an individial patient's data or 'A' to check all patients." G 1
- S YSN=$S("I"[A:0,1:1),YSD=0,YSE=0 G:'YSN 2
- R !!,"(L)ist or (D)elete errors: ",A:DTIME S YSTOUT='$T,YSUOUT=A["^" G:YSTOUT!YSUOUT KIL S A=$TR($E(A),"ld","LD") I "LD"'[A W:A'["?" " ?",$C(7) G S
- S YSD=$S("D"[A:1,1:0)
- 2 ;
- R !!,"Shall I list discontinued session(s)" S %=0 D YN^DICN G:"^"[%Y KIL I %Y["?" W !?4,"Answer 'YES' or 'NO'." G 2
- S YSL=$S(%=1:1,1:0) I 'YSN D ^YSLRP G:YSDFN<1 KIL S P=YSDFN D P1 G:YSDFN<1 KIL D INC:YSL,T G END
- S %ZIS="Q" D ^%ZIS G:POP KIL I $D(IO("Q")) S ZTRTN="ENP^YTCHECK",ZTSAVE("YS*")="",ZTDESC="YS DB CHECK" D ^%ZTLOAD G KIL
- ENP ;
- U IO D HD S (P,P(0))=0,P1="" F S P=$O(^YTD(601.2,P)) Q:'P D P,T
- I YSL S P=0 F S P=$O(^YTD(601.4,P)) Q:'P S YSNM=$S($D(^DPT(P,0)):$P(^(0),U),1:"UNKNOWN PATIENT") D INC
- G END
- CK ;
- ;G:'$D(^YTT(601,T,0)) CK1 S L=$P(^(0),U,11),L1=0 S:$G(^YTD(601.2,P,1,T,1,D,99))="MMPIR" L=1132 L +^YTD(601.2,P) S I=0 F S I=$O(^YTD(601.2,P,1,T,1,D,I)) Q:'I!(I>50) S L1=L1+$L(^(I))
- G:'$D(^YTT(601,T,0)) CK1
- S L=$P(^(0),U,11),L1=0
- L +^YTD(601.2,P) S I=0
- F S I=$O(^YTD(601.2,P,1,T,1,D,I)) Q:'I!(I>50) S L1=L1+$L(^(I))
- ;
- ; 3/10/94 LJA Changes made to display MMPR correctly, when it is...
- L -^YTD(601.2,P)
- I L'=L1,$$MMPIRCK(L,L1) D
- . S YSE=YSE+1 D:IOST?1"P".E HD:$Y+9>IOSL W ! W:YSN YSNM
- . W ?31,"Response set length error on " S X=$P(^YTT(601,T,0),U)
- . ; Following line commented on 4/29/94. LJA.
- . ;I L'=L1,T=60,$G(^YTD(601.2,+P,1,+T,1,+D,99))="MMPIR" S X="MMPIR"
- . ;
- . W X,!?31,"expected ",L," got ",L1
- . D DEL:'YSN
- . I YSD K ^YTD(601.2,+P,1,+T,1,+D) W " - DELETED" QUIT
- CK1 ;
- S D(0)=D(0)+1,C=D
- QUIT
- ;
- MMPIRCK(L,L1) ; If MMPIR and EXP=566 and GOT=1132... OK
- ; This code "compensates" for MMPR longs (MMPIs) entered before
- ; YS*5*17. These entries still have 1132 (2 x 566) responses...
- ;
- ; Report 1 (ok) if anything other than an MMPIR
- I $G(^YTD(601.2,+P,1,+T,1,+D,99))'="MMPIR" QUIT 1 ;->
- ;
- ; This is an MMPIR...
- QUIT '(L=566&(L1=1132))
- ;
- D ;
- S D(0)=0 I '$D(^YTT(601,T,0)) S YSE=YSE+1 D:IOST?1"P".E HD:$Y+8>IOSL W ! W:YSN YSNM W ?31,"Unknown Instrument" S X="instrument" D DEL:'YSN I YSD K ^YTD(601.2,P,1,T),^YTD(601.2,P,1,"B",T) W " - DELETED" Q
- S D=0 F S D=$O(^YTD(601.2,P,1,T,1,D)) Q:'D D CK
- I D(0)>0 L +^YTD(601.2,P,1,T,1,0) S ^YTD(601.2,P,1,T,1,0)="^601.22DA^"_C_"^"_D(0) L -^YTD(601.2,P,1,T,1,0) S:'$D(^YTD(601.2,P,1,"B",T,T)) ^(T)="" Q
- K ^YTD(601.2,P,1,T) Q
- T ;
- S (T(0),T)=0 F S T=$O(^YTD(601.2,P,1,T)) Q:'T D D I D(0)>0 S T(0)=T(0)+1,H=T S:'$D(^YTD(601.2,P,1,"B",T,T)) ^(T)=""
- I T(0)>0 L +^YTD(601.2,P,1,0) S ^YTD(601.2,P,1,0)="^601.21PA^"_H_"^"_T(0) L -^YTD(601.2,P,1,0) S:YSN P(0)=P(0)+1,P1=P
- I T(0)>0 S I=0 F S I=$O(^YTD(601.2,P,1,"B",I)) Q:'I K:'$D(^YTD(601.2,P,1,I,0)) ^YTD(601.2,P,1,"B",I)
- Q:T(0) K ^YTD(601.2,P),^YTD(601.2,"B",P) Q:YSN L +^YTD(601.2,0) S X=$P(^YTD(601.2,0),U,4),X=X-1 S:X<1 X=0 S $P(^(0),U,4)=X L -^YTD(601.2,0) Q
- P ;
- S YSDFN=P,YSNM=$S($D(^DPT(P,0)):$P(^(0),U),1:"Unknown Patient") I '$D(^DPT(P,0)) S YSE=YSE+1 D:IOST?1"P".E HD:$Y+8>IOSL W !,"Unknown patient found" I YSD K ^YTD(601.2,P),^YTD(601.2,"B",P,P) W " - DELETED" Q
- P1 I 'YSN,'$D(^YTD(601.2,P)),'$D(^YTD(601.4,P)) W !,"No data on this patient." S YSDFN=-1 Q
- S:'$D(^YTD(601.2,"B",P,P)) ^(P)="" Q
- Q
- INC ;
- I $O(^YTD(601.4,P,1,0))>0 D:IOST?1"P".E HD:$Y+8>IOSL W ! W:YSN YSNM W ?31,"Incomplete Session(s) found"
- Q
- DEL ;
- S YSD=0 W !!,"DELETE this ",X,"? " R A:DTIME S YSTOUT='$T,YSUOUT=A["^" Q:YSTOUT!YSUOUT S A=$E(A) I "YyNn"'[A W:A'["?" " ?",$C(7) G DEL
- S:"Yy"[A YSD=1 Q
- END ;
- I YSN L +^YTD(601.2,0) S $P(^YTD(601.2,0),U,3)=P1,$P(^(0),U,4)=P(0) L -^YTD(601.2,0) D KILL^%ZTLOAD
- W:'YSE !!,"NO ERRORS FOUND" W ! D:YSN ^%ZISC
- KIL ;
- K %,%ZIS,%Y,A,C,D,H,I,IO("Q"),L,L1,P,P1,T,X,Y,YSAGE,YSD,YSDFN,YSDOB,YSL,YSN,YSNM,YSSEX,YSSSN,ZTSK Q
- HD ;
- W @IOF,!,"Test/Interview Database Report on " S Y=DT D DT^YTAUDIT W !! Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTCHECK 4924 printed Mar 13, 2025@21:21:58 Page 2
- YTCHECK ;SLC/TGA-CHECK PSYCH TEST/INTERVIEW DATA BASE ; 7/10/89 11:21 ;03/11/94 12:13
- +1 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
- +2 ;
- +3 ; Called from the top by MENU option YSMCHK
- +4 ;
- S ;
- +1 WRITE @IOF,?22,"Check Psych Test/Interview Data Base"
- +2 WRITE !!,"You may use this option for individual patients or all patients."
- +3 WRITE !,"If you use it for individual patients, you may elect to delete any unknown"
- +4 WRITE !,"tests/interviews and any tests/interviews with erroneous response sets."
- +5 WRITE !,"If you use it for all patients, you may elect to print a list of errors or"
- +6 WRITE !,"automatically delete all unknown patients, unknown instruments, and all"
- +7 WRITE !,"instruments with erroneous response sets."
- +8 WRITE !!,"THIS OPTION SHOULD NOT BE RUN WHILE TESTS/INTERVIEWS ARE UNDERWAY!",$CHAR(7)
- 1 ;
- +1 WRITE !!,"Check (I)ndividual patient or (A)ll patients: I// "
- READ A:DTIME
- SET YSTOUT='$TEST
- SET YSUOUT=A["^"
- if YSTOUT!YSUOUT
- GOTO KIL
- SET A=$TRANSLATE($EXTRACT(A),"ia","IA")
- +2 IF "AI"'[A
- if A'["?"
- WRITE " ?",$CHAR(7)
- WRITE !,"Type 'I' to check an individial patient's data or 'A' to check all patients."
- GOTO 1
- +3 SET YSN=$SELECT("I"[A:0,1:1)
- SET YSD=0
- SET YSE=0
- if 'YSN
- GOTO 2
- +4 READ !!,"(L)ist or (D)elete errors: ",A:DTIME
- SET YSTOUT='$TEST
- SET YSUOUT=A["^"
- if YSTOUT!YSUOUT
- GOTO KIL
- SET A=$TRANSLATE($EXTRACT(A),"ld","LD")
- IF "LD"'[A
- if A'["?"
- WRITE " ?",$CHAR(7)
- GOTO S
- +5 SET YSD=$SELECT("D"[A:1,1:0)
- 2 ;
- +1 READ !!,"Shall I list discontinued session(s)"
- SET %=0
- DO YN^DICN
- if "^"[%Y
- GOTO KIL
- IF %Y["?"
- WRITE !?4,"Answer 'YES' or 'NO'."
- GOTO 2
- +2 SET YSL=$SELECT(%=1:1,1:0)
- IF 'YSN
- DO ^YSLRP
- if YSDFN<1
- GOTO KIL
- SET P=YSDFN
- DO P1
- if YSDFN<1
- GOTO KIL
- if YSL
- DO INC
- DO T
- GOTO END
- +3 SET %ZIS="Q"
- DO ^%ZIS
- if POP
- GOTO KIL
- IF $DATA(IO("Q"))
- SET ZTRTN="ENP^YTCHECK"
- SET ZTSAVE("YS*")=""
- SET ZTDESC="YS DB CHECK"
- DO ^%ZTLOAD
- GOTO KIL
- ENP ;
- +1 USE IO
- DO HD
- SET (P,P(0))=0
- SET P1=""
- FOR
- SET P=$ORDER(^YTD(601.2,P))
- if 'P
- QUIT
- DO P
- DO T
- +2 IF YSL
- SET P=0
- FOR
- SET P=$ORDER(^YTD(601.4,P))
- if 'P
- QUIT
- SET YSNM=$SELECT($DATA(^DPT(P,0)):$PIECE(^(0),U),1:"UNKNOWN PATIENT")
- DO INC
- +3 GOTO END
- CK ;
- +1 ;G:'$D(^YTT(601,T,0)) CK1 S L=$P(^(0),U,11),L1=0 S:$G(^YTD(601.2,P,1,T,1,D,99))="MMPIR" L=1132 L +^YTD(601.2,P) S I=0 F S I=$O(^YTD(601.2,P,1,T,1,D,I)) Q:'I!(I>50) S L1=L1+$L(^(I))
- +2 if '$DATA(^YTT(601,T,0))
- GOTO CK1
- +3 SET L=$PIECE(^(0),U,11)
- SET L1=0
- +4 LOCK +^YTD(601.2,P)
- SET I=0
- +5 FOR
- SET I=$ORDER(^YTD(601.2,P,1,T,1,D,I))
- if 'I!(I>50)
- QUIT
- SET L1=L1+$LENGTH(^(I))
- +6 ;
- +7 ; 3/10/94 LJA Changes made to display MMPR correctly, when it is...
- +8 LOCK -^YTD(601.2,P)
- +9 IF L'=L1
- IF $$MMPIRCK(L,L1)
- Begin DoDot:1
- +10 SET YSE=YSE+1
- if IOST?1"P".E
- if $Y+9>IOSL
- DO HD
- WRITE !
- if YSN
- WRITE YSNM
- +11 WRITE ?31,"Response set length error on "
- SET X=$PIECE(^YTT(601,T,0),U)
- +12 ; Following line commented on 4/29/94. LJA.
- +13 ;I L'=L1,T=60,$G(^YTD(601.2,+P,1,+T,1,+D,99))="MMPIR" S X="MMPIR"
- +14 ;
- +15 WRITE X,!?31,"expected ",L," got ",L1
- +16 if 'YSN
- DO DEL
- +17 IF YSD
- KILL ^YTD(601.2,+P,1,+T,1,+D)
- WRITE " - DELETED"
- QUIT
- End DoDot:1
- CK1 ;
- +1 SET D(0)=D(0)+1
- SET C=D
- +2 QUIT
- +3 ;
- MMPIRCK(L,L1) ; If MMPIR and EXP=566 and GOT=1132... OK
- +1 ; This code "compensates" for MMPR longs (MMPIs) entered before
- +2 ; YS*5*17. These entries still have 1132 (2 x 566) responses...
- +3 ;
- +4 ; Report 1 (ok) if anything other than an MMPIR
- +5 ;->
- IF $GET(^YTD(601.2,+P,1,+T,1,+D,99))'="MMPIR"
- QUIT 1
- +6 ;
- +7 ; This is an MMPIR...
- +8 QUIT '(L=566&(L1=1132))
- +9 ;
- D ;
- +1 SET D(0)=0
- IF '$DATA(^YTT(601,T,0))
- SET YSE=YSE+1
- if IOST?1"P".E
- if $Y+8>IOSL
- DO HD
- WRITE !
- if YSN
- WRITE YSNM
- WRITE ?31,"Unknown Instrument"
- SET X="instrument"
- if 'YSN
- DO DEL
- IF YSD
- KILL ^YTD(601.2,P,1,T),^YTD(601.2,P,1,"B",T)
- WRITE " - DELETED"
- QUIT
- +2 SET D=0
- FOR
- SET D=$ORDER(^YTD(601.2,P,1,T,1,D))
- if 'D
- QUIT
- DO CK
- +3 IF D(0)>0
- LOCK +^YTD(601.2,P,1,T,1,0)
- SET ^YTD(601.2,P,1,T,1,0)="^601.22DA^"_C_"^"_D(0)
- LOCK -^YTD(601.2,P,1,T,1,0)
- if '$DATA(^YTD(601.2,P,1,"B",T,T))
- SET ^(T)=""
- QUIT
- +4 KILL ^YTD(601.2,P,1,T)
- QUIT
- T ;
- +1 SET (T(0),T)=0
- FOR
- SET T=$ORDER(^YTD(601.2,P,1,T))
- if 'T
- QUIT
- DO D
- IF D(0)>0
- SET T(0)=T(0)+1
- SET H=T
- if '$DATA(^YTD(601.2,P,1,"B",T,T))
- SET ^(T)=""
- +2 IF T(0)>0
- LOCK +^YTD(601.2,P,1,0)
- SET ^YTD(601.2,P,1,0)="^601.21PA^"_H_"^"_T(0)
- LOCK -^YTD(601.2,P,1,0)
- if YSN
- SET P(0)=P(0)+1
- SET P1=P
- +3 IF T(0)>0
- SET I=0
- FOR
- SET I=$ORDER(^YTD(601.2,P,1,"B",I))
- if 'I
- QUIT
- if '$DATA(^YTD(601.2,P,1,I,0))
- KILL ^YTD(601.2,P,1,"B",I)
- +4 if T(0)
- QUIT
- KILL ^YTD(601.2,P),^YTD(601.2,"B",P)
- if YSN
- QUIT
- LOCK +^YTD(601.2,0)
- SET X=$PIECE(^YTD(601.2,0),U,4)
- SET X=X-1
- if X<1
- SET X=0
- SET $PIECE(^(0),U,4)=X
- LOCK -^YTD(601.2,0)
- QUIT
- P ;
- +1 SET YSDFN=P
- SET YSNM=$SELECT($DATA(^DPT(P,0)):$PIECE(^(0),U),1:"Unknown Patient")
- IF '$DATA(^DPT(P,0))
- SET YSE=YSE+1
- if IOST?1"P".E
- if $Y+8>IOSL
- DO HD
- WRITE !,"Unknown patient found"
- IF YSD
- KILL ^YTD(601.2,P),^YTD(601.2,"B",P,P)
- WRITE " - DELETED"
- QUIT
- P1 IF 'YSN
- IF '$DATA(^YTD(601.2,P))
- IF '$DATA(^YTD(601.4,P))
- WRITE !,"No data on this patient."
- SET YSDFN=-1
- QUIT
- +1 if '$DATA(^YTD(601.2,"B",P,P))
- SET ^(P)=""
- QUIT
- +2 QUIT
- INC ;
- +1 IF $ORDER(^YTD(601.4,P,1,0))>0
- if IOST?1"P".E
- if $Y+8>IOSL
- DO HD
- WRITE !
- if YSN
- WRITE YSNM
- WRITE ?31,"Incomplete Session(s) found"
- +2 QUIT
- DEL ;
- +1 SET YSD=0
- WRITE !!,"DELETE this ",X,"? "
- READ A:DTIME
- SET YSTOUT='$TEST
- SET YSUOUT=A["^"
- if YSTOUT!YSUOUT
- QUIT
- SET A=$EXTRACT(A)
- IF "YyNn"'[A
- if A'["?"
- WRITE " ?",$CHAR(7)
- GOTO DEL
- +2 if "Yy"[A
- SET YSD=1
- QUIT
- END ;
- +1 IF YSN
- LOCK +^YTD(601.2,0)
- SET $PIECE(^YTD(601.2,0),U,3)=P1
- SET $PIECE(^(0),U,4)=P(0)
- LOCK -^YTD(601.2,0)
- DO KILL^%ZTLOAD
- +2 if 'YSE
- WRITE !!,"NO ERRORS FOUND"
- WRITE !
- if YSN
- DO ^%ZISC
- KIL ;
- +1 KILL %,%ZIS,%Y,A,C,D,H,I,IO("Q"),L,L1,P,P1,T,X,Y,YSAGE,YSD,YSDFN,YSDOB,YSL,YSN,YSNM,YSSEX,YSSSN,ZTSK
- QUIT
- HD ;
- +1 WRITE @IOF,!,"Test/Interview Database Report on "
- SET Y=DT
- DO DT^YTAUDIT
- WRITE !!
- QUIT
