YSMTI ;ALB/ASF - MUTLIPLE PSYCH TESTS AND INTERVIEWS ;7/23/99 09:50
;;5.01;MENTAL HEALTH;**53,187**;Dec 30, 1994;Build 73
;
W @IOF,!?10,"Psychological Testing Mutliple Administraion Reporting",!
PTALL ; SELECT PT
W ! K DIC,DIK S YSDFN=0,DIC("A")="Select Patient: ",DIC="^YTD(601.2,",DIC(0)="AEQ" D ^DIC Q:Y'>0 S YSDFN=+Y
K ^TMP("YSMTI",$J,YSDFN)
I $O(^YTD(601.2,YSDFN,1,0))'>0 W !,"No Tests found" Q
SELTST ;select test
K DIC S DIC="^YTD(601.2,YSDFN,1,",DIC(0)="AEMZ" D ^DIC Q:Y'>0 S (YSET,YSTEST)=+Y,YSTESTA=$P(^YTT(601,YSTEST,0),U)
I $P(^YTT(601,YSTEST,0),U,9)'="T" W !,"Only Tests can be graphed" H 2 G SELTST
D ENFRNT
SELSCAL ;
S Y="N" I YSTESTA?1."MMP".E!(YSTESTA?1"MCMI".E) K DIR S DIR("A")="Show Full Profile? ",DIR("B")="NO",DIR(0)="Y" D ^DIR Q:$D(DIROUT)
I Y=1 D ^YSMTI0 G SELSCAL
K DIC S DIC("A")="Select Scale Number or Name: ",DIC(0)="AEQZM",DIC="^YTT(601,YSTEST,"""_"S"_""",",DIC("W")="W ?10,$P(^(0),U,2)" D ^DIC G:Y'>0 SELTST S YSCALEN=+Y,YSCALET=$P(Y(0),U,2)
K IOP S %ZIS="Q" D ^%ZIS Q:POP
I $D(IO("Q")) K IO("Q") S ZTRTN="ENTASK^YSMTI",ZTDESC="YSMTI" S ZTSAVE("YS*")="" D ^%ZTLOAD W !,$S($D(ZTSK):"QUEUED",1:"Not queued"),$C(7) G SELSCAL
U IO D HDR,CR,HOME^%ZIS D ^%ZISC U IO
G SELSCAL
ENTASK ;taskman entry
S:$D(ZTQUEUED) ZTREQ="@"
D ENFRNT,HDR,CR Q
HDR ;
S YSLN="",$P(YSLN,"_",79)=""
W @IOF,!?7,"**** M U L T I P L E T E S T A D M I N I S T R A T I O N S ****"
W !,VADM(1),?40,"SSN: xxx-xx-"_$E($P(VADM(2),U,2),8,11)," ",$P(VADM(5),U,2),?60," DOB: ",$P(VADM(3),U,2)
S X=$P(^YTT(601,YSTEST,"P"),U) W !?(72-$L(X)/2),X
S X="Scale: "_YSCALET W !,YSLN,!?(72-$L(X)/2),X,!,YSLN
W !,"Entered: Days between Raw Scaled"
Q
CR ;loop thru TMP
S (YSED,YSED1)=0 F S YSED=$O(^TMP("YSMTI",$J,YSDFN,YSTEST,YSCALEN,YSED)) Q:YSED'>0 D CR1 S YSED1=YSED
W !! Q
CR1 S Y=^TMP("YSMTI",$J,YSDFN,YSTEST,YSCALEN,YSED)
S R=$P(Y,U),S=$P(Y,U,2) S:YSED1 YSED1=$$FMDIFF^XLFDT(YSED,YSED1,1)
;W !,$E(YSED,4,5)_"/"_$E(YSED,6,7)_"/"_$E(YSED,2,3),?12,$S(YSED1:$J(YSED1,5),1:" "),?22,$J(R,6)," ",$J(S,6)
W !,$$FMTE^XLFDT(YSED,"5ZD"),?14,$S(YSED1:$J(YSED1,5),1:" "),?24,$J(R,6)," ",$J(S,6)
Q
ENFRNT ;
S YSET=YSTEST,DFN=YSDFN D DEM^VADPT,PID^VADPT
S YSNM=VADM(1),(YSSX,YSSEX)=$P(VADM(5),U),YSDOB=$P(VADM(3),U,2),YSAGE=VADM(4),YSSSN=VA("PID")
LK2 ;LOOP THRU DATES
S (YSDAT,YSED)=0 F S YSED=$O(^YTD(601.2,YSDFN,1,YSTEST,1,YSED)) Q:YSED'>0 S YSDAT=YSED D EXEC,FSD
Q
EXEC ;SELECT TYPE OF TEST AND EXECUTE PROPER RTN
K S,R S YSTN=$P(^YTT(601,YSTEST,0),U) Q:'$D(^YTT(601,YSTEST,"R")) S X=^YTT(601,YSTEST,"R")
S YSR(0)=$G(^YTT(601.6,YSET,0))
I $P(YSR(0),U,2)="Y" S X=^YTT(601.6,YSET,1) X X
Q
FSD ;file scale data
I '$D(R) S ^TMP("YSMTI",$J,YSDFN,YSET,1,YSED)="" Q
I $L(R) F I=1:1 Q:$P(R,U,I)="" S ^TMP("YSMTI",$J,YSDFN,YSET,I,YSED)=$P(R,U,I) S:$D(S) $P(^(YSED),U,2)=$P(S,U,I)
S I1=0,YSCALEN=0 F S I1=$O(R(I1)) Q:I1'>0 D FSD1
Q
FSD1 ;
F I=1:1 Q:$P(R(I1),U,I)="" S YSCALEN=YSCALEN+1,^TMP("YSMTI",$J,YSDFN,YSET,YSCALEN,YSED)=$P(R(I1),U,I) S:$D(S(I1)) $P(^(YSED),U,2)=$P(S(I1),U,I)
Q
FRONT ; front end output
S YSDFN=P3,(YSET,YSTEST)=P4,YSNSCALE=P5 K ^TMP("YSMTI",$J)
D ENFRNT
W "11111<BOT>",$C(13)
FOUT2 S YSED=0 F S YSED=$O(^TMP("YSMTI",$J,YSDFN,YSET,YSNSCALE,YSED)) Q:YSED'>0 D FRONT1
W "<EOT>",$C(13) Q
FRONT1 S Y=^TMP("YSMTI",$J,YSDFN,YSET,YSNSCALE,YSED)
;S Y1=$P(^YTT(601,YSET,0),U,1)_U_$E(YSED,4,5)_"/"_$E(YSED,6,7)_"/"_$E(YSED,2,3)_U_$S(+Y:YSNSCALE,1:"")_U_$P(Y,U,1)_U_$P(Y,U,2)
S Y1=$P(^YTT(601,YSET,0),U,1)_U_$$FMTE^XLFDT(YSED,"5ZD")_U_$S(+Y:YSNSCALE,1:"")_U_$P(Y,U,1)_U_$P(Y,U,2)
W Y1,$C(13)
Q
TLIST ;list of tests for a pt
S YSDFN=P3 W "11111<BOT>",$C(13)
S YSTEST=0 F S YSTEST=$O(^YTD(601.2,YSDFN,1,YSTEST)) Q:YSTEST'>0 I $D(^YTT(601,YSTEST,0)) W YSTEST_U_$P(^YTT(601,YSTEST,0),U)_U_$P(^YTT(601,YSTEST,"P"),"---",2)_$C(13)
W "<EOT>",$C(13) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSMTI 3893 printed Dec 13, 2024@02:14:44 Page 2
YSMTI ;ALB/ASF - MUTLIPLE PSYCH TESTS AND INTERVIEWS ;7/23/99 09:50
+1 ;;5.01;MENTAL HEALTH;**53,187**;Dec 30, 1994;Build 73
+2 ;
+3 WRITE @IOF,!?10,"Psychological Testing Mutliple Administraion Reporting",!
PTALL ; SELECT PT
+1 WRITE !
KILL DIC,DIK
SET YSDFN=0
SET DIC("A")="Select Patient: "
SET DIC="^YTD(601.2,"
SET DIC(0)="AEQ"
DO ^DIC
if Y'>0
QUIT
SET YSDFN=+Y
+2 KILL ^TMP("YSMTI",$JOB,YSDFN)
+3 IF $ORDER(^YTD(601.2,YSDFN,1,0))'>0
WRITE !,"No Tests found"
QUIT
SELTST ;select test
+1 KILL DIC
SET DIC="^YTD(601.2,YSDFN,1,"
SET DIC(0)="AEMZ"
DO ^DIC
if Y'>0
QUIT
SET (YSET,YSTEST)=+Y
SET YSTESTA=$PIECE(^YTT(601,YSTEST,0),U)
+2 IF $PIECE(^YTT(601,YSTEST,0),U,9)'="T"
WRITE !,"Only Tests can be graphed"
HANG 2
GOTO SELTST
+3 DO ENFRNT
SELSCAL ;
+1 SET Y="N"
IF YSTESTA?1."MMP".E!(YSTESTA?1"MCMI".E)
KILL DIR
SET DIR("A")="Show Full Profile? "
SET DIR("B")="NO"
SET DIR(0)="Y"
DO ^DIR
if $DATA(DIROUT)
QUIT
+2 IF Y=1
DO ^YSMTI0
GOTO SELSCAL
+3 KILL DIC
SET DIC("A")="Select Scale Number or Name: "
SET DIC(0)="AEQZM"
SET DIC="^YTT(601,YSTEST,"""_"S"_""","
SET DIC("W")="W ?10,$P(^(0),U,2)"
DO ^DIC
if Y'>0
GOTO SELTST
SET YSCALEN=+Y
SET YSCALET=$PIECE(Y(0),U,2)
+4 KILL IOP
SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
+5 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN="ENTASK^YSMTI"
SET ZTDESC="YSMTI"
SET ZTSAVE("YS*")=""
DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"QUEUED",1:"Not queued"),$CHAR(7)
GOTO SELSCAL
+6 USE IO
DO HDR
DO CR
DO HOME^%ZIS
DO ^%ZISC
USE IO
+7 GOTO SELSCAL
ENTASK ;taskman entry
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 DO ENFRNT
DO HDR
DO CR
QUIT
HDR ;
+1 SET YSLN=""
SET $PIECE(YSLN,"_",79)=""
+2 WRITE @IOF,!?7,"**** M U L T I P L E T E S T A D M I N I S T R A T I O N S ****"
+3 WRITE !,VADM(1),?40,"SSN: xxx-xx-"_$EXTRACT($PIECE(VADM(2),U,2),8,11)," ",$PIECE(VADM(5),U,2),?60," DOB: ",$PIECE(VADM(3),U,2)
+4 SET X=$PIECE(^YTT(601,YSTEST,"P"),U)
WRITE !?(72-$LENGTH(X)/2),X
+5 SET X="Scale: "_YSCALET
WRITE !,YSLN,!?(72-$LENGTH(X)/2),X,!,YSLN
+6 WRITE !,"Entered: Days between Raw Scaled"
+7 QUIT
CR ;loop thru TMP
+1 SET (YSED,YSED1)=0
FOR
SET YSED=$ORDER(^TMP("YSMTI",$JOB,YSDFN,YSTEST,YSCALEN,YSED))
if YSED'>0
QUIT
DO CR1
SET YSED1=YSED
+2 WRITE !!
QUIT
CR1 SET Y=^TMP("YSMTI",$JOB,YSDFN,YSTEST,YSCALEN,YSED)
+1 SET R=$PIECE(Y,U)
SET S=$PIECE(Y,U,2)
if YSED1
SET YSED1=$$FMDIFF^XLFDT(YSED,YSED1,1)
+2 ;W !,$E(YSED,4,5)_"/"_$E(YSED,6,7)_"/"_$E(YSED,2,3),?12,$S(YSED1:$J(YSED1,5),1:" "),?22,$J(R,6)," ",$J(S,6)
+3 WRITE !,$$FMTE^XLFDT(YSED,"5ZD"),?14,$SELECT(YSED1:$JUSTIFY(YSED1,5),1:" "),?24,$JUSTIFY(R,6)," ",$JUSTIFY(S,6)
+4 QUIT
ENFRNT ;
+1 SET YSET=YSTEST
SET DFN=YSDFN
DO DEM^VADPT
DO PID^VADPT
+2 SET YSNM=VADM(1)
SET (YSSX,YSSEX)=$PIECE(VADM(5),U)
SET YSDOB=$PIECE(VADM(3),U,2)
SET YSAGE=VADM(4)
SET YSSSN=VA("PID")
LK2 ;LOOP THRU DATES
+1 SET (YSDAT,YSED)=0
FOR
SET YSED=$ORDER(^YTD(601.2,YSDFN,1,YSTEST,1,YSED))
if YSED'>0
QUIT
SET YSDAT=YSED
DO EXEC
DO FSD
+2 QUIT
EXEC ;SELECT TYPE OF TEST AND EXECUTE PROPER RTN
+1 KILL S,R
SET YSTN=$PIECE(^YTT(601,YSTEST,0),U)
if '$DATA(^YTT(601,YSTEST,"R"))
QUIT
SET X=^YTT(601,YSTEST,"R")
+2 SET YSR(0)=$GET(^YTT(601.6,YSET,0))
+3 IF $PIECE(YSR(0),U,2)="Y"
SET X=^YTT(601.6,YSET,1)
XECUTE X
+4 QUIT
FSD ;file scale data
+1 IF '$DATA(R)
SET ^TMP("YSMTI",$JOB,YSDFN,YSET,1,YSED)=""
QUIT
+2 IF $LENGTH(R)
FOR I=1:1
if $PIECE(R,U,I)=""
QUIT
SET ^TMP("YSMTI",$JOB,YSDFN,YSET,I,YSED)=$PIECE(R,U,I)
if $DATA(S)
SET $PIECE(^(YSED),U,2)=$PIECE(S,U,I)
+3 SET I1=0
SET YSCALEN=0
FOR
SET I1=$ORDER(R(I1))
if I1'>0
QUIT
DO FSD1
+4 QUIT
FSD1 ;
+1 FOR I=1:1
if $PIECE(R(I1),U,I)=""
QUIT
SET YSCALEN=YSCALEN+1
SET ^TMP("YSMTI",$JOB,YSDFN,YSET,YSCALEN,YSED)=$PIECE(R(I1),U,I)
if $DATA(S(I1))
SET $PIECE(^(YSED),U,2)=$PIECE(S(I1),U,I)
+2 QUIT
FRONT ; front end output
+1 SET YSDFN=P3
SET (YSET,YSTEST)=P4
SET YSNSCALE=P5
KILL ^TMP("YSMTI",$JOB)
+2 DO ENFRNT
+3 WRITE "11111<BOT>",$CHAR(13)
FOUT2 SET YSED=0
FOR
SET YSED=$ORDER(^TMP("YSMTI",$JOB,YSDFN,YSET,YSNSCALE,YSED))
if YSED'>0
QUIT
DO FRONT1
+1 WRITE "<EOT>",$CHAR(13)
QUIT
FRONT1 SET Y=^TMP("YSMTI",$JOB,YSDFN,YSET,YSNSCALE,YSED)
+1 ;S Y1=$P(^YTT(601,YSET,0),U,1)_U_$E(YSED,4,5)_"/"_$E(YSED,6,7)_"/"_$E(YSED,2,3)_U_$S(+Y:YSNSCALE,1:"")_U_$P(Y,U,1)_U_$P(Y,U,2)
+2 SET Y1=$PIECE(^YTT(601,YSET,0),U,1)_U_$$FMTE^XLFDT(YSED,"5ZD")_U_$SELECT(+Y:YSNSCALE,1:"")_U_$PIECE(Y,U,1)_U_$PIECE(Y,U,2)
+3 WRITE Y1,$CHAR(13)
+4 QUIT
TLIST ;list of tests for a pt
+1 SET YSDFN=P3
WRITE "11111<BOT>",$CHAR(13)
+2 SET YSTEST=0
FOR
SET YSTEST=$ORDER(^YTD(601.2,YSDFN,1,YSTEST))
if YSTEST'>0
QUIT
IF $DATA(^YTT(601,YSTEST,0))
WRITE YSTEST_U_$PIECE(^YTT(601,YSTEST,0),U)_U_$PIECE(^YTT(601,YSTEST,"P"),"---",2)_$CHAR(13)
+3 WRITE "<EOT>",$CHAR(13)
QUIT
