- YTDP ;SLC/TGA-PRINT & DUPLICATE REPORTS ;11/27/91 15:02
- ;;5.01;MENTAL HEALTH;**37,41,54**;Dec 30, 1994
- ;
- S YSXT="" S:'$D(T1) T1=0 W !!?10,"--- Previous ",$S('T1:"Instruments",1:T1(0)_"(s)")," ---",! I 'YSNT D DIS W !?10,"No Completed ",$S('T1:"Instruments",1:T1(0)_"(s)")," Found",! H 3 G KAR^YTS
- S B=$S(YSNT<11:YSNT,1:YSNT+1\2)
- F K=1:1:B S YSDT=$P(A1(K),U,2) D DAT W !?10,$J(K,3,0)," ",$P(A1(K),U) W ?22,YSDT I B'=YSNT,$D(A1(B+K)) W ?50,$J(B+K,3,0)," ",$P(A1(B+K),U) S YSDT=$P(A1(B+K),U,2) D DAT W ?62,YSDT
- D DIS W !!?10,"--- Print ",$S('T1:"Instruments",1:T1(0)_"(s)")," ---",!
- DU ;
- W !?10,"Select ",$S('T1:"Instrument",1:T1(0))," # : " R M:DTIME S YSTOUT='$T,YSUOUT=M["^" G KAR^YTS:YSTOUT!YSUOUT,D1:M=""
- I M'?1.3N!(M<1)!(M>YSNT) W:M'["?" " [Not Valid # or out of Range]" W !!?10,"Type ONLY the NUMBER of the instrument you wish to print",! G DU
- S YSXT=YSXT_$P(A1(M),U,2)_","_$P(A1(M),U,3)_"^" G:$L(YSXT,U)<22 DU
- D1 ;
- I YSXT="" G KAR^YTS
- RP ;
- W !!,"Type 'Q' to queue to a printer.",! S %ZIS="Q" D ^%ZIS G:POP KAR^YTS
- I $D(IO("Q")),IO=IO(0),IOST'?1"P".E W !,$C(7),"You must QUEUE to a PRINTER!" G RP
- I $D(IO("Q")) K IO("Q") S ZTRTN="RP1^YTDP",ZTSAVE("YS*")="",ZTDESC="YS DUP REPORT" D ^%ZTLOAD W:$D(ZTSK) !!,"Your Task Number is "_ZTSK G KAR^YTS
- RP1 ;
- S:$D(ZTQUEUED) ZTREQ="@"
- S YSXTP=1,P0=$S(IOST?1"P".E:1,1:0),YSLFT=0 U IO
- RP10 ;
- S YSTEST=$P(YSXT,U,YSXTP) I YSTEST="" D KILL^%ZTLOAD G KAR^YTS
- I YSTEST[",",$P(^YTT(601,$P(YSTEST,",",2),0),U,9)="B" S YSTESTS=YSTEST F S YSXTP=$G(YSXTP)+1 S:$D(YSXT) YSTEST=$P(YSXT,U,YSXTP) Q:$G(YSTEST)=""!(YSXTP=1) D CONB
- I $G(YSTEST)="" S YSTEST=YSTESTS K YSTESTS G:'$D(^YTT(601,$P(YSTEST,",",2),"R")) KAR^YTS
- CONB I YSTEST["," S (YSHD,YSDT)=$P(YSTEST,",") D DAT S YSHDR=$E(YSHDR,1,61)_" "_YSDT,YSED=$P(YSTEST,","),(YSET,YSTEST)=$P(YSTEST,",",2)
- I '$D(YSTESTS) G:'$D(^YTT(601,YSTEST,"R")) KAR^YTS
- X:^YTT(601,YSTEST,"R")]"" ^("R")
- G:$D(YSFORM) RP21 I $P(^YTT(601,YSTEST,0),U,6)]"" S YSCH=$P(^(0),U,6),Y=$P(^(0),U,7) D DD^%DT S YSCD=Y I $D(^YTT(601.3,YSCH,0)) S YSCHN=YSCH,YSCH=$P(^(0),U) D CR G:YSLFT RP21
- G:'P0 RP11 I IOSL-$Y<7 D DTA^YTREPT W !!!
- E F I=1:1:IOSL-$Y-5 W !
- W "Not valid unless signed: Reviewed by ................................",!,"Printed by: ",$P(^VA(200,DUZ,0),U)," "
- S YSORD=$P(^YTD(601.2,YSDFN,1,YSET,1,YSED,0),U,3)
- W ! I YSORD,$D(^VA(200,YSORD,0)) W "Ordered by: ",$P(^(0),U)
- RP11 ;
- I $D(^YTD(601.2,YSDFN,1,YSET,1,YSED,"R",0)),$P(^(0),U,4)>0 D:'P0 SCR1 G:YSUOUT RP21 D ^YTDP1 G:YSLFT RP21
- I $P(^YTT(601,YSTEST,0),U,9)="T" D:'P0 SCR1 G:YSLFT RP21 D:'$D(YSNOITEM) IR^YTREPT D:$D(YSNOITEM) @YSNOITEM
- RP21 ;
- K J,R,S,X,YSFORM,YSMX,YSNOITEM ;Q:YSTOUT!YSUOUT I $D(P0) D:'P0 SCR1
- S:YSTOUT!YSUOUT YSXT="" S YSXTP=YSXTP+1 G RP10
- DAT ;
- S YSDT=$$FMTE^XLFDT(YSDT,"5ZD") Q
- DIS ;
- Q:'$D(^YTD(601.4,YSDFN,1,"B")) W !!?10,"Discontinued Instruments Exist",! Q
- CR ;
- S P1=$S(P0:"I IOSL-$Y<15",1:"I IOSL-$Y<9")
- X P1 D CK:$T Q:YSLFT I YSCH="IPAT"!(YSCH="PSYC") S YSTNM=$P($P(^YTT(601,YSTEST,"P"),U),"---",2),YSTNM=$E(YSTNM,1,$L(YSTNM)-1) G IP:YSCH="IPAT",PS:YSCH="PSYC"
- W !!!?3,^YTT(601.3,YSCHN,1,1,0)," ",YSCD," ",^YTT(601.3,YSCHN,1,2,0) S YSTX=2
- NL ;
- S YSTX=$O(^YTT(601.3,YSCHN,1,YSTX)) Q:'YSTX W !?3,^(YSTX,0) G NL
- IP ;
- W !!!?3,^YTT(601.3,YSCHN,1,1,0) W !?3,^YTT(601.3,YSCHN,1,2,0),YSTNM,",",!?3,^YTT(601.3,YSCHN,1,3,0)," ",YSCD," ",^YTT(601.3,YSCHN,1,4,0),!?3,^YTT(601.3,YSCHN,1,5,0) K YSCH,YSCHN,YSCD,YSTX,YSTNM Q
- PS ;
- W !!!?3,^YTT(601.3,YSCHN,1,1,0),YSTNM W !?3,^YTT(601.3,YSCHN,1,2,0)," ",YSCD,!?3,^YTT(601.3,YSCHN,1,3,0)," ",^YTT(601.3,YSCHN,1,4,0) K YSCH,YSCHN,YSCD,YSTX,YSTNM Q
- SCR1 ;
- ; Added 5/6/94 LJA
- N A,B,B1,C,D,E,E1,F,F1,G,G1,H,I,J,J1,J2,J3,J4,K,L,L1,L2,M,N
- N N1,N2,N3,N4,P,P0,P1,P3,R,R1,S,S1,T,T1,T2,TT,V,V1,V2,V3
- N V4,V5,V6,W,X,X0,X1,X2,X3,X4,X7,X8,X9,Y,Y1,Y2,Z,Z1,Z3
- ;
- Q:YSLFT F I0=1:1:(IOSL-$Y-2) W !
- N DTOUT,DUOUT,DIRUT
- S DIR(0)="E" D ^DIR K DIR S YSTOUT=$D(DTOUT),YSUOUT=$D(DUOUT),YSLFT=YSTOUT
- W @IOF Q
- CK ;
- D SCR1:'P0 Q:YSUOUT!YSTOUT D:P0 DTA^YTREPT Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTDP 4041 printed Mar 13, 2025@21:22:05 Page 2
- YTDP ;SLC/TGA-PRINT & DUPLICATE REPORTS ;11/27/91 15:02
- +1 ;;5.01;MENTAL HEALTH;**37,41,54**;Dec 30, 1994
- +2 ;
- +3 SET YSXT=""
- if '$DATA(T1)
- SET T1=0
- WRITE !!?10,"--- Previous ",$SELECT('T1:"Instruments",1:T1(0)_"(s)")," ---",!
- IF 'YSNT
- DO DIS
- WRITE !?10,"No Completed ",$SELECT('T1:"Instruments",1:T1(0)_"(s)")," Found",!
- HANG 3
- GOTO KAR^YTS
- +4 SET B=$SELECT(YSNT<11:YSNT,1:YSNT+1\2)
- +5 FOR K=1:1:B
- SET YSDT=$PIECE(A1(K),U,2)
- DO DAT
- WRITE !?10,$JUSTIFY(K,3,0)," ",$PIECE(A1(K),U)
- WRITE ?22,YSDT
- IF B'=YSNT
- IF $DATA(A1(B+K))
- WRITE ?50,$JUSTIFY(B+K,3,0)," ",$PIECE(A1(B+K),U)
- SET YSDT=$PIECE(A1(B+K),U,2)
- DO DAT
- WRITE ?62,YSDT
- +6 DO DIS
- WRITE !!?10,"--- Print ",$SELECT('T1:"Instruments",1:T1(0)_"(s)")," ---",!
- DU ;
- +1 WRITE !?10,"Select ",$SELECT('T1:"Instrument",1:T1(0))," # : "
- READ M:DTIME
- SET YSTOUT='$TEST
- SET YSUOUT=M["^"
- if YSTOUT!YSUOUT
- GOTO KAR^YTS
- if M=""
- GOTO D1
- +2 IF M'?1.3N!(M<1)!(M>YSNT)
- if M'["?"
- WRITE " [Not Valid # or out of Range]"
- WRITE !!?10,"Type ONLY the NUMBER of the instrument you wish to print",!
- GOTO DU
- +3 SET YSXT=YSXT_$PIECE(A1(M),U,2)_","_$PIECE(A1(M),U,3)_"^"
- if $LENGTH(YSXT,U)<22
- GOTO DU
- D1 ;
- +1 IF YSXT=""
- GOTO KAR^YTS
- RP ;
- +1 WRITE !!,"Type 'Q' to queue to a printer.",!
- SET %ZIS="Q"
- DO ^%ZIS
- if POP
- GOTO KAR^YTS
- +2 IF $DATA(IO("Q"))
- IF IO=IO(0)
- IF IOST'?1"P".E
- WRITE !,$CHAR(7),"You must QUEUE to a PRINTER!"
- GOTO RP
- +3 IF $DATA(IO("Q"))
- KILL IO("Q")
- SET ZTRTN="RP1^YTDP"
- SET ZTSAVE("YS*")=""
- SET ZTDESC="YS DUP REPORT"
- DO ^%ZTLOAD
- if $DATA(ZTSK)
- WRITE !!,"Your Task Number is "_ZTSK
- GOTO KAR^YTS
- RP1 ;
- +1 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +2 SET YSXTP=1
- SET P0=$SELECT(IOST?1"P".E:1,1:0)
- SET YSLFT=0
- USE IO
- RP10 ;
- +1 SET YSTEST=$PIECE(YSXT,U,YSXTP)
- IF YSTEST=""
- DO KILL^%ZTLOAD
- GOTO KAR^YTS
- +2 IF YSTEST[","
- IF $PIECE(^YTT(601,$PIECE(YSTEST,",",2),0),U,9)="B"
- SET YSTESTS=YSTEST
- FOR
- SET YSXTP=$GET(YSXTP)+1
- if $DATA(YSXT)
- SET YSTEST=$PIECE(YSXT,U,YSXTP)
- if $GET(YSTEST)=""!(YSXTP=1)
- QUIT
- DO CONB
- +3 IF $GET(YSTEST)=""
- SET YSTEST=YSTESTS
- KILL YSTESTS
- if '$DATA(^YTT(601,$PIECE(YSTEST,",",2),"R"))
- GOTO KAR^YTS
- CONB IF YSTEST[","
- SET (YSHD,YSDT)=$PIECE(YSTEST,",")
- DO DAT
- SET YSHDR=$EXTRACT(YSHDR,1,61)_" "_YSDT
- SET YSED=$PIECE(YSTEST,",")
- SET (YSET,YSTEST)=$PIECE(YSTEST,",",2)
- +1 IF '$DATA(YSTESTS)
- if '$DATA(^YTT(601,YSTEST,"R"))
- GOTO KAR^YTS
- +2 if ^YTT(601,YSTEST,"R")]""
- XECUTE ^("R")
- +3 if $DATA(YSFORM)
- GOTO RP21
- IF $PIECE(^YTT(601,YSTEST,0),U,6)]""
- SET YSCH=$PIECE(^(0),U,6)
- SET Y=$PIECE(^(0),U,7)
- DO DD^%DT
- SET YSCD=Y
- IF $DATA(^YTT(601.3,YSCH,0))
- SET YSCHN=YSCH
- SET YSCH=$PIECE(^(0),U)
- DO CR
- if YSLFT
- GOTO RP21
- +4 if 'P0
- GOTO RP11
- IF IOSL-$Y<7
- DO DTA^YTREPT
- WRITE !!!
- +5 IF '$TEST
- FOR I=1:1:IOSL-$Y-5
- WRITE !
- +6 WRITE "Not valid unless signed: Reviewed by ................................",!,"Printed by: ",$PIECE(^VA(200,DUZ,0),U)," "
- +7 SET YSORD=$PIECE(^YTD(601.2,YSDFN,1,YSET,1,YSED,0),U,3)
- +8 WRITE !
- IF YSORD
- IF $DATA(^VA(200,YSORD,0))
- WRITE "Ordered by: ",$PIECE(^(0),U)
- RP11 ;
- +1 IF $DATA(^YTD(601.2,YSDFN,1,YSET,1,YSED,"R",0))
- IF $PIECE(^(0),U,4)>0
- if 'P0
- DO SCR1
- if YSUOUT
- GOTO RP21
- DO ^YTDP1
- if YSLFT
- GOTO RP21
- +2 IF $PIECE(^YTT(601,YSTEST,0),U,9)="T"
- if 'P0
- DO SCR1
- if YSLFT
- GOTO RP21
- if '$DATA(YSNOITEM)
- DO IR^YTREPT
- if $DATA(YSNOITEM)
- DO @YSNOITEM
- RP21 ;
- +1 ;Q:YSTOUT!YSUOUT I $D(P0) D:'P0 SCR1
- KILL J,R,S,X,YSFORM,YSMX,YSNOITEM
- +2 if YSTOUT!YSUOUT
- SET YSXT=""
- SET YSXTP=YSXTP+1
- GOTO RP10
- DAT ;
- +1 SET YSDT=$$FMTE^XLFDT(YSDT,"5ZD")
- QUIT
- DIS ;
- +1 if '$DATA(^YTD(601.4,YSDFN,1,"B"))
- QUIT
- WRITE !!?10,"Discontinued Instruments Exist",!
- QUIT
- CR ;
- +1 SET P1=$SELECT(P0:"I IOSL-$Y<15",1:"I IOSL-$Y<9")
- +2 XECUTE P1
- if $TEST
- DO CK
- if YSLFT
- QUIT
- IF YSCH="IPAT"!(YSCH="PSYC")
- SET YSTNM=$PIECE($PIECE(^YTT(601,YSTEST,"P"),U),"---",2)
- SET YSTNM=$EXTRACT(YSTNM,1,$LENGTH(YSTNM)-1)
- if YSCH="IPAT"
- GOTO IP
- if YSCH="PSYC"
- GOTO PS
- +3 WRITE !!!?3,^YTT(601.3,YSCHN,1,1,0)," ",YSCD," ",^YTT(601.3,YSCHN,1,2,0)
- SET YSTX=2
- NL ;
- +1 SET YSTX=$ORDER(^YTT(601.3,YSCHN,1,YSTX))
- if 'YSTX
- QUIT
- WRITE !?3,^(YSTX,0)
- GOTO NL
- IP ;
- +1 WRITE !!!?3,^YTT(601.3,YSCHN,1,1,0)
- WRITE !?3,^YTT(601.3,YSCHN,1,2,0),YSTNM,",",!?3,^YTT(601.3,YSCHN,1,3,0)," ",YSCD," ",^YTT(601.3,YSCHN,1,4,0),!?3,^YTT(601.3,YSCHN,1,5,0)
- KILL YSCH,YSCHN,YSCD,YSTX,YSTNM
- QUIT
- PS ;
- +1 WRITE !!!?3,^YTT(601.3,YSCHN,1,1,0),YSTNM
- WRITE !?3,^YTT(601.3,YSCHN,1,2,0)," ",YSCD,!?3,^YTT(601.3,YSCHN,1,3,0)," ",^YTT(601.3,YSCHN,1,4,0)
- KILL YSCH,YSCHN,YSCD,YSTX,YSTNM
- QUIT
- SCR1 ;
- +1 ; Added 5/6/94 LJA
- +2 NEW A,B,B1,C,D,E,E1,F,F1,G,G1,H,I,J,J1,J2,J3,J4,K,L,L1,L2,M,N
- +3 NEW N1,N2,N3,N4,P,P0,P1,P3,R,R1,S,S1,T,T1,T2,TT,V,V1,V2,V3
- +4 NEW V4,V5,V6,W,X,X0,X1,X2,X3,X4,X7,X8,X9,Y,Y1,Y2,Z,Z1,Z3
- +5 ;
- +6 if YSLFT
- QUIT
- FOR I0=1:1:(IOSL-$Y-2)
- WRITE !
- +7 NEW DTOUT,DUOUT,DIRUT
- +8 SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- SET YSTOUT=$DATA(DTOUT)
- SET YSUOUT=$DATA(DUOUT)
- SET YSLFT=YSTOUT
- +9 WRITE @IOF
- QUIT
- CK ;
- +1 if 'P0
- DO SCR1
- if YSUOUT!YSTOUT
- QUIT
- if P0
- DO DTA^YTREPT
- QUIT
