- YIHISTF ;SLC/DKG-INTERVIEW HISTORY DRIVER (Cont) ; 10/18/88 13:40 ;
- ;;5.01;MENTAL HEALTH;;Dec 30, 1994
- CK ;
- Q:'$T
- CK1 ;
- S:P0 YSCON=1 D WAIT:'P0,ENFT^YSFORM:P0 Q:YSLFT D HDR:P0 Q
- L ;
- S Y1=$E(YSYTX,1,78-YSIND),Y2=$E(YSYTX,79-YSIND,255)
- I Y2="" X P1 D CK Q:YSLFT W !?YSIND,Y1 Q
- F YSYI=78-YSIND:-1:1 I $E(Y1,YSYI)?1P X P1 D CK Q:YSLFT W !?YSIND,$E(Y1,1,YSYI) S YSYTX=$E(Y1,YSYI+1,78-YSIND)_Y2 Q
- I $E(Y1,YSYI)'?1P X P1 D CK Q:YSLFT W !?YSIND,Y1 S YSYTX=Y2
- G L
- ;
- RP ;
- S J=1,U1=0,L=-200,YSLCK=200,YSFHDR=$P(^YTT(601,YSTEST,"P"),U,4),YSCON=0,YSFTR=$P(^YTT(601,YSTEST,"P"),U,5),YSLFT=0,YSFORM=1,YSXR="Patient Report"
- S P1=$S(IOST?1"C-".E:"I IOSL-$Y<3",1:"I IOSL-$Y<7"),P3=$S(P1[3:"I IOSL-$Y<6",1:"I IOSL-$Y<10"),P0=$S(P1[3:0,1:1) D HDR
- R1 ;
- I '$D(^YTT(601,YSTEST,"G",J,1,1,0)) D PC,ENFT^YSFORM:P0 K A,B,D,DIW,DIWF,DIWL,DIWR,DIWT,DN,DW2,DWI,I,YSI,YSJ,YSU,YSXR,YSIND,J,L,YSLCK,R,YSSTEM,U1,YSYX,YSYCK,YSSCK Q
- S A=^YTT(601,YSTEST,"G",J,1,1,0),J=J+1,B=$P(A,U),I=+B,YSIND=$P(B,",",2)
- I I=0 G:$P(A,U,3)="OMIT" R1 X P3 D CK G:YSLFT END W !!?YSIND,$P(A,U,2),! S YSLCK=200 G R1
- I I'>L!(I>U1) S L=(I-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
- S R=$E(YSYX,I-L) G:R=" " R1
- S YSSTEM=$P(A,U,2) G:YSSTEM'["##" YSRP1 S YSSCK=$S(YSSTEM["2":2,YSSTEM["1":1,1:0) I YSSTEM["L" S YSLCK=YSIND,YSYCK=$P(A,U,3) G R1
- I YSSCK X P3 D CK G:YSLFT END
- W:YSSCK ! W !?YSIND,$P(A,U,3) W:YSSCK=2 ! G R1
- YSRP1 ;
- I "YN"[R S R=R="N"+1 I YSSTEM'["#" S R=$P(A,U,R+1) G NOST:R'="",R1
- S R=$P(A,U,R+2) G R1:R="",NOST:YSSTEM=""
- D:YSIND>YSLCK STM G:YSLFT END
- I YSSTEM'["#" S YSYTX=YSSTEM_R D L G R1:'YSLFT,END
- S A=$F(YSSTEM,"#") I A<3 S YSYTX=R_$E(YSSTEM,2,99) D L G R1:'YSLFT,END
- S YSYTX=$E(YSSTEM,1,A-2)_R_$E(YSSTEM,A,99) D L G R1:'YSLFT,END
- NOST ;
- D:YSIND>YSLCK STM G:YSLFT END S YSYTX=R D L G R1:'YSLFT,END
- STM ;
- I YSSCK X P3 D CK Q:YSLFT
- W:YSSCK ! W !?YSLCK,YSYCK W:YSSCK=2 ! S YSLCK=200 Q
- WH ;
- W !,$P(^YTT(601,YSTEST,0),U)," QUESTION # ",J,! H 2 G @(R1)
- HDR ;
- W @IOF I P0 W ! F I=1:1:80 W "-"
- I P0 W !,"MEDICAL RECORD"
- W ?(80-$L(YSFHDR)/2),YSFHDR I P0 W ! F I=1:1:80 W "-"
- I YSCON W !?25,"(Continued from previous page)" S YSCON=0
- W !?(80-$L(YSXR)\2),YSXR,":" Q
- WAIT ;
- F I0=1:1:IOSL-$Y-2 W !
- N DTOUT,DUOUT,DIRUT
- S DIR(0)="E" D ^DIR K DIR S YSLFT=$D(DIRUT) W @IOF
- Q
- END ;
- K P0,P1,P3,YSFHDR,YSCON,YSFTR,A,B,I,J,L,YSIND,YSLCK,R,YSSTEM,YSYX,YSYCK,YSSCK,Y1,Y2,YSYI,YSYTX Q
- PC ;
- S YSXR="Staff Report" I $Y+$S(P0:10,1:5)>IOSL D CK1 Q:YSLFT
- E W !!?34,YSXR
- S YSI=0 F S YSI=$O(^YTD(601.2,YSDFN,1,YSET,1,YSED,"R","AD",YSI)) Q:'YSI Q:YSLFT S YSJ=0 F S YSJ=$O(^YTD(601.2,YSDFN,1,YSET,1,YSED,"R","AD",YSI,YSJ)) Q:'YSJ Q:'$D(^YTD(601.2,YSDFN,1,YSET,1,YSED,"R",YSJ,0)) S X=^(0) D PC1 Q:YSLFT
- K D,DIW,DIWF,DIWL,DIWR,DIWT,DN,DW2,DWI,I,YSI,YSJ,YSU Q
- PC1 ;
- S YSU=$P(X,U,4) Q:YSU<1 D:$Y+$S(P0:11,1:6)>IOSL CK1 Q:YSLFT
- S Y=YSI D DD^%DT W !!,Y S DIC="^YTD(601.2,YSDFN,1,YSET,1,YSED,""R"",YSJ,1,",DIWL=1,DIWR=80,DIWF="W",DWI="F D=1:1:DW2 S X="_DIC_"D,0) D:$Y+$S(P0:12,1:7)>IOSL CK1 Q:YSLFT D ^DIWP"
- S Z=DIC_"0)",DW2=$P(@(Z),U,4) D:$Y+$S(P0:10,1:5)>IOSL CK1 Q:YSLFT W !! X DWI Q:YSLFT D:$Y+$S(P0:11,1:5)>IOSL CK1 D ^DIWW D:$Y+$S(P0:10,1:4)>IOSL CK1 Q:YSLFT W ! W:P0 !! W $P($G(^VA(200,+YSU,0)),U)
- I P0 W !,"NOT VALID UNLESS SIGNED - NOT TO BE FILED IN MEDICAL RECORD UNLESS SIGNED" Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYIHISTF 3358 printed Mar 13, 2025@21:16:42 Page 2
- YIHISTF ;SLC/DKG-INTERVIEW HISTORY DRIVER (Cont) ; 10/18/88 13:40 ;
- +1 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
- CK ;
- +1 if '$TEST
- QUIT
- CK1 ;
- +1 if P0
- SET YSCON=1
- if 'P0
- DO WAIT
- if P0
- DO ENFT^YSFORM
- if YSLFT
- QUIT
- if P0
- DO HDR
- QUIT
- L ;
- +1 SET Y1=$EXTRACT(YSYTX,1,78-YSIND)
- SET Y2=$EXTRACT(YSYTX,79-YSIND,255)
- +2 IF Y2=""
- XECUTE P1
- DO CK
- if YSLFT
- QUIT
- WRITE !?YSIND,Y1
- QUIT
- +3 FOR YSYI=78-YSIND:-1:1
- IF $EXTRACT(Y1,YSYI)?1P
- XECUTE P1
- DO CK
- if YSLFT
- QUIT
- WRITE !?YSIND,$EXTRACT(Y1,1,YSYI)
- SET YSYTX=$EXTRACT(Y1,YSYI+1,78-YSIND)_Y2
- QUIT
- +4 IF $EXTRACT(Y1,YSYI)'?1P
- XECUTE P1
- DO CK
- if YSLFT
- QUIT
- WRITE !?YSIND,Y1
- SET YSYTX=Y2
- +5 GOTO L
- +6 ;
- RP ;
- +1 SET J=1
- SET U1=0
- SET L=-200
- SET YSLCK=200
- SET YSFHDR=$PIECE(^YTT(601,YSTEST,"P"),U,4)
- SET YSCON=0
- SET YSFTR=$PIECE(^YTT(601,YSTEST,"P"),U,5)
- SET YSLFT=0
- SET YSFORM=1
- SET YSXR="Patient Report"
- +2 SET P1=$SELECT(IOST?1"C-".E:"I IOSL-$Y<3",1:"I IOSL-$Y<7")
- SET P3=$SELECT(P1[3:"I IOSL-$Y<6",1:"I IOSL-$Y<10")
- SET P0=$SELECT(P1[3:0,1:1)
- DO HDR
- R1 ;
- +1 IF '$DATA(^YTT(601,YSTEST,"G",J,1,1,0))
- DO PC
- if P0
- DO ENFT^YSFORM
- KILL A,B,D,DIW,DIWF,DIWL,DIWR,DIWT,DN,DW2,DWI,I,YSI,YSJ,YSU,YSXR,YSIND,J,L,YSLCK,R,YSSTEM,U1,YSYX,YSYCK,YSSCK
- QUIT
- +2 SET A=^YTT(601,YSTEST,"G",J,1,1,0)
- SET J=J+1
- SET B=$PIECE(A,U)
- SET I=+B
- SET YSIND=$PIECE(B,",",2)
- +3 IF I=0
- if $PIECE(A,U,3)="OMIT"
- GOTO R1
- XECUTE P3
- DO CK
- if YSLFT
- GOTO END
- WRITE !!?YSIND,$PIECE(A,U,2),!
- SET YSLCK=200
- GOTO R1
- +4 IF I'>L!(I>U1)
- SET L=(I-1)\200*200
- SET U1=L+200
- SET YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
- +5 SET R=$EXTRACT(YSYX,I-L)
- if R=" "
- GOTO R1
- +6 SET YSSTEM=$PIECE(A,U,2)
- if YSSTEM'["##"
- GOTO YSRP1
- SET YSSCK=$SELECT(YSSTEM["2":2,YSSTEM["1":1,1:0)
- IF YSSTEM["L"
- SET YSLCK=YSIND
- SET YSYCK=$PIECE(A,U,3)
- GOTO R1
- +7 IF YSSCK
- XECUTE P3
- DO CK
- if YSLFT
- GOTO END
- +8 if YSSCK
- WRITE !
- WRITE !?YSIND,$PIECE(A,U,3)
- if YSSCK=2
- WRITE !
- GOTO R1
- YSRP1 ;
- +1 IF "YN"[R
- SET R=R="N"+1
- IF YSSTEM'["#"
- SET R=$PIECE(A,U,R+1)
- if R'=""
- GOTO NOST
- GOTO R1
- +2 SET R=$PIECE(A,U,R+2)
- if R=""
- GOTO R1
- if YSSTEM=""
- GOTO NOST
- +3 if YSIND>YSLCK
- DO STM
- if YSLFT
- GOTO END
- +4 IF YSSTEM'["#"
- SET YSYTX=YSSTEM_R
- DO L
- if 'YSLFT
- GOTO R1
- GOTO END
- +5 SET A=$FIND(YSSTEM,"#")
- IF A<3
- SET YSYTX=R_$EXTRACT(YSSTEM,2,99)
- DO L
- if 'YSLFT
- GOTO R1
- GOTO END
- +6 SET YSYTX=$EXTRACT(YSSTEM,1,A-2)_R_$EXTRACT(YSSTEM,A,99)
- DO L
- if 'YSLFT
- GOTO R1
- GOTO END
- NOST ;
- +1 if YSIND>YSLCK
- DO STM
- if YSLFT
- GOTO END
- SET YSYTX=R
- DO L
- if 'YSLFT
- GOTO R1
- GOTO END
- STM ;
- +1 IF YSSCK
- XECUTE P3
- DO CK
- if YSLFT
- QUIT
- +2 if YSSCK
- WRITE !
- WRITE !?YSLCK,YSYCK
- if YSSCK=2
- WRITE !
- SET YSLCK=200
- QUIT
- WH ;
- +1 WRITE !,$PIECE(^YTT(601,YSTEST,0),U)," QUESTION # ",J,!
- HANG 2
- GOTO @(R1)
- HDR ;
- +1 WRITE @IOF
- IF P0
- WRITE !
- FOR I=1:1:80
- WRITE "-"
- +2 IF P0
- WRITE !,"MEDICAL RECORD"
- +3 WRITE ?(80-$LENGTH(YSFHDR)/2),YSFHDR
- IF P0
- WRITE !
- FOR I=1:1:80
- WRITE "-"
- +4 IF YSCON
- WRITE !?25,"(Continued from previous page)"
- SET YSCON=0
- +5 WRITE !?(80-$LENGTH(YSXR)\2),YSXR,":"
- QUIT
- WAIT ;
- +1 FOR I0=1:1:IOSL-$Y-2
- WRITE !
- +2 NEW DTOUT,DUOUT,DIRUT
- +3 SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- SET YSLFT=$DATA(DIRUT)
- WRITE @IOF
- +4 QUIT
- END ;
- +1 KILL P0,P1,P3,YSFHDR,YSCON,YSFTR,A,B,I,J,L,YSIND,YSLCK,R,YSSTEM,YSYX,YSYCK,YSSCK,Y1,Y2,YSYI,YSYTX
- QUIT
- PC ;
- +1 SET YSXR="Staff Report"
- IF $Y+$SELECT(P0:10,1:5)>IOSL
- DO CK1
- if YSLFT
- QUIT
- +2 IF '$TEST
- WRITE !!?34,YSXR
- +3 SET YSI=0
- FOR
- SET YSI=$ORDER(^YTD(601.2,YSDFN,1,YSET,1,YSED,"R","AD",YSI))
- if 'YSI
- QUIT
- if YSLFT
- QUIT
- SET YSJ=0
- FOR
- SET YSJ=$ORDER(^YTD(601.2,YSDFN,1,YSET,1,YSED,"R","AD",YSI,YSJ))
- if 'YSJ
- QUIT
- if '$DATA(^YTD(601.2,YSDFN,1,YSET,1,YSED,"R",YSJ,0))
- QUIT
- SET X=^(0)
- DO PC1
- if YSLFT
- QUIT
- +4 KILL D,DIW,DIWF,DIWL,DIWR,DIWT,DN,DW2,DWI,I,YSI,YSJ,YSU
- QUIT
- PC1 ;
- +1 SET YSU=$PIECE(X,U,4)
- if YSU<1
- QUIT
- if $Y+$SELECT(P0
- DO CK1
- if YSLFT
- QUIT
- +2 SET Y=YSI
- DO DD^%DT
- WRITE !!,Y
- SET DIC="^YTD(601.2,YSDFN,1,YSET,1,YSED,""R"",YSJ,1,"
- SET DIWL=1
- SET DIWR=80
- SET DIWF="W"
- SET DWI="F D=1:1:DW2 S X="_DIC_"D,0) D:$Y+$S(P0:12,1:7)>IOSL CK1 Q:YSLFT D ^DIWP"
- +3 SET Z=DIC_"0)"
- SET DW2=$PIECE(@(Z),U,4)
- if $Y+$SELECT(P0
- DO CK1
- if YSLFT
- QUIT
- WRITE !!
- XECUTE DWI
- if YSLFT
- QUIT
- if $Y+$SELECT(P0
- DO CK1
- DO ^DIWW
- if $Y+$SELECT(P0
- DO CK1
- if YSLFT
- QUIT
- WRITE !
- if P0
- WRITE !!
- WRITE $PIECE($GET(^VA(200,+YSU,0)),U)
- +4 IF P0
- WRITE !,"NOT VALID UNLESS SIGNED - NOT TO BE FILED IN MEDICAL RECORD UNLESS SIGNED"
- QUIT
