YTRPWRP ;DALOI/YH - Report Calls ;Nov 13, 2023@09:16:25
;;5.01;MENTAL HEALTH;**71,76,96,60,187,218,238**;Dec 30, 1994;Build 25
;
;Reference to VADPT APIs supported by DBIA #10061
;Reference to ^XLFDT APIs supported by DBIA #10103
;Reference to ^%ZISC supported by IA #10089
;Reference to ^%ZIS supported by IA #10086
;Reference to %ZISH supported by DBIA #2320
;Reference to DT^DICRW supported by DBIA #10005
;
INTRMNT(ROOT,YSDFN,YSXT) ; -- return report text
;ROOT=Where you want it
;YSDFN=Patient DFN
;YSXT= DATE TEST TAKEN,POINTER TO MH INSTRUMENT FILE #601
; RPC: MH INTRUMENT REPORT TEXT
;
; -- init output global for close logic of WORKSTATION device
N YSTOUT,YSUOUT,YSTEST,YSED,YSET,DFN,YSROU,YSN,LEN,YSBLNK,YSSIG S (YSTOUT,YSUOUT,YSN)=0,DFN=+YSDFN,$P(YSBLNK," ",60)=""
S %=$H>21549+$H-.1,%Y=%\365.25+141,%=%#365.25\1,YSPTD=%+306#(%Y#4=0+365)#153#61#31+1,YSPTM=%-YSPTD\29+1,Y=%Y_"00"+YSPTM_"00"+YSPTD,YSDT(0)=$$FMTE^XLFDT(Y,"5ZD")
D DEM^VADPT,PID^VADPT
S YSNM=VADM(1)
S YSDOB=$P(VADM(3),U,2)
S YSAGE=VADM(4)
S YSSSN="xxx-xx-"_VA("BID")
S YSSEX=$P(VADM(5),U,1)
S YSSX=YSSEX
S YSSIG=$P($G(VADM(14,5)),U,2)
S YSHDR=YSSSN_" "_YSNM_YSBLNK
S YSHDR=$E(YSHDR,1,44)_$S(YSSIG'="":YSSIG,1:YSSEX)_" AGE "_YSAGE
S YSHD=DT
K ^TMP("YSDATA",$J)
S ROOT=$NA(^TMP("YSDATA",$J,1))
; -- get report text
D START(132,"RP1^YTDP")
Q
;
START(RM,GOTO) ;
;RM=Right margin
S:'$G(RM) RM=80
N ZTQUEUED,YSHFS,YSSUB,YSIO
K ^TMP("YSDATA",$J)
S ROOT=$NA(^TMP("YSDATA",$J,1))
S YSHFS=$$HFS(),YSSUB="YSDATA"
D OPEN(.RM,.YSHFS,"W",.YSIO)
D @GOTO
D CLOSE(.YSRM,.YSHFS,.YSSUB,.YSIO)
Q
HFS() ; -- get hfs file name
; -- need to define better unique algorithm
Q "YSU_"_$J_".DAT"
;
OPEN(YSRM,YSHFS,YSMODE,YSIO) ; -- open WORKSTATION device
; YSRM: right margin
; YSHFS: host file name
; YSMODE: open file in 'R'ead or 'W'rite mode
S ZTQUEUED="" K IOPAR
S IOP="OR WORKSTATION;"_$G(YSRM,80)_";66"
S %ZIS("HFSMODE")=YSMODE,%ZIS("HFSNAME")=YSHFS
D ^%ZIS
K IOP,%ZIS
U IO
S YSIO=IO
Q
;
CLOSE(YSRM,YSHFS,YSSUB,YSIO) ; -- close WORKSTATION device
; YSSUB: unique subscript name for output
I IO=YSIO D ^%ZISC
U IO
D USEHFS
U IO
Q
USEHFS ; -- use host file to build global array
N IO,YSOK,SECTION
S SECTION=0
D INIT
S YSOK=$$FTG^%ZISH(,YSHFS,$NA(@ROOT@(1)),4) I 'YSOK Q
D STRIP
N YSARR S YSARR(YSHFS)=""
S YSOK=$$DEL^%ZISH("",$NA(YSARR))
Q
;
INIT ; -- initialize counts and global section
S (INC,CNT)=0,SECTION=SECTION+1
S ROOT=$NA(^TMP(YSSUB,$J,SECTION))
K @ROOT
Q
;
STRIP ; -- strip off control chars
N I,X
S I=0 F S I=$O(@ROOT@(I)) Q:'I S X=^(I) D
. I X[$C(8) D ;BS
.. I $L(X,$C(8))=$L(X,$C(95)) S (X,@ROOT@(I))=$TR(X,$C(8,95),"") Q ;BS & _
.. S (X,@ROOT@(I))=$TR(X,$C(8),"")
. I X[$C(7)!(X[$C(12)) S @ROOT@(I)=$TR(X,$C(7,12),"") ;BEL or FF
. I X[$C(12)&(I>7) S @ROOT@(I+.5)="***eop***"_$C(10) ;asf 4/18/08
Q
;
TESTCODE(ROOT) ;YTRP LIST TEST/CODE
N A S A="C"
D START(132,"ENP^YTLCTD")
Q
TESTDES(ROOT) ;YTRP LIST TEST/DESC
N A S A="D"
D START(132,"ENP^YTLCTD")
Q
TESTTL(ROOT) ;YTRP LIST TEST/TITLE
N A S A="T"
D START(132,"ENP^YTLCTD")
Q
;
; Hrubovcak - 30 March 2012
;
AL60193 ; strip control chars. from all entries in MH REPORT (#601.93)
;
D DT^DICRW
N YSI S YSI=0
F S YSI=$O(^YTT(601.93,YSI)) Q:'(YSI>0) D:$O(^YTT(601.93,YSI,1,0)) ; if W-P field exists
.L +^YTT(601.93,YSI):DILOCKTM E Q ; exclusive access
.D RMVCC(YSI) L -^YTT(601.93,YSI)
;
Q
;
RMVCC(YSIEN) ; remove control chars. from W-P field in MH REPORT (#601.93)
; entry should be LOCKed before call
N J,X,Y ; X=original, Y=fixed
S J=0
F S J=$O(^YTT(601.93,YSIEN,1,J)) Q:'J S X=$G(^YTT(601.93,YSIEN,1,J,0)) I X]"" S Y=X D
.N FLAG ; indicates what was done
.I Y[$C(8) D ; backspace
..I $L(Y,$C(8))=$L(Y,$C(95)) S Y=$TR(Y,$C(8,95),""),FLAG("BSUN")=1 Q ; backspace & underscore
..S Y=$TR(Y,$C(8),""),FLAG("BS")=1 ; backspace
.;
.I Y[$C(7)!(Y[$C(12)) S:Y[$C(12) FLAG("FF")=1 S:Y[$C(7) FLAG("BELL")=1 S Y=$TR(Y,$C(7,12),"") ; bell or form feed
.Q:Y=X ; no changes
.S ^YTT(601.93,YSIEN,1,J,0)=Y
.I J>7,$G(FLAG("FF")) S ^YTT(601.93,YSIEN,1,J+.5,0)="***eop***"_$C(10)
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTRPWRP 4270 printed Oct 16, 2024@18:19:49 Page 2
YTRPWRP ;DALOI/YH - Report Calls ;Nov 13, 2023@09:16:25
+1 ;;5.01;MENTAL HEALTH;**71,76,96,60,187,218,238**;Dec 30, 1994;Build 25
+2 ;
+3 ;Reference to VADPT APIs supported by DBIA #10061
+4 ;Reference to ^XLFDT APIs supported by DBIA #10103
+5 ;Reference to ^%ZISC supported by IA #10089
+6 ;Reference to ^%ZIS supported by IA #10086
+7 ;Reference to %ZISH supported by DBIA #2320
+8 ;Reference to DT^DICRW supported by DBIA #10005
+9 ;
INTRMNT(ROOT,YSDFN,YSXT) ; -- return report text
+1 ;ROOT=Where you want it
+2 ;YSDFN=Patient DFN
+3 ;YSXT= DATE TEST TAKEN,POINTER TO MH INSTRUMENT FILE #601
+4 ; RPC: MH INTRUMENT REPORT TEXT
+5 ;
+6 ; -- init output global for close logic of WORKSTATION device
+7 NEW YSTOUT,YSUOUT,YSTEST,YSED,YSET,DFN,YSROU,YSN,LEN,YSBLNK,YSSIG
SET (YSTOUT,YSUOUT,YSN)=0
SET DFN=+YSDFN
SET $PIECE(YSBLNK," ",60)=""
+8 SET %=$HOROLOG>21549+$HOROLOG-.1
SET %Y=%\365.25+141
SET %=%#365.25\1
SET YSPTD=%+306#(%Y#4=0+365)#153#61#31+1
SET YSPTM=%-YSPTD\29+1
SET Y=%Y_"00"+YSPTM_"00"+YSPTD
SET YSDT(0)=$$FMTE^XLFDT(Y,"5ZD")
+9 DO DEM^VADPT
DO PID^VADPT
+10 SET YSNM=VADM(1)
+11 SET YSDOB=$PIECE(VADM(3),U,2)
+12 SET YSAGE=VADM(4)
+13 SET YSSSN="xxx-xx-"_VA("BID")
+14 SET YSSEX=$PIECE(VADM(5),U,1)
+15 SET YSSX=YSSEX
+16 SET YSSIG=$PIECE($GET(VADM(14,5)),U,2)
+17 SET YSHDR=YSSSN_" "_YSNM_YSBLNK
+18 SET YSHDR=$EXTRACT(YSHDR,1,44)_$SELECT(YSSIG'="":YSSIG,1:YSSEX)_" AGE "_YSAGE
+19 SET YSHD=DT
+20 KILL ^TMP("YSDATA",$JOB)
+21 SET ROOT=$NAME(^TMP("YSDATA",$JOB,1))
+22 ; -- get report text
+23 DO START(132,"RP1^YTDP")
+24 QUIT
+25 ;
START(RM,GOTO) ;
+1 ;RM=Right margin
+2 if '$GET(RM)
SET RM=80
+3 NEW ZTQUEUED,YSHFS,YSSUB,YSIO
+4 KILL ^TMP("YSDATA",$JOB)
+5 SET ROOT=$NAME(^TMP("YSDATA",$JOB,1))
+6 SET YSHFS=$$HFS()
SET YSSUB="YSDATA"
+7 DO OPEN(.RM,.YSHFS,"W",.YSIO)
+8 DO @GOTO
+9 DO CLOSE(.YSRM,.YSHFS,.YSSUB,.YSIO)
+10 QUIT
HFS() ; -- get hfs file name
+1 ; -- need to define better unique algorithm
+2 QUIT "YSU_"_$JOB_".DAT"
+3 ;
OPEN(YSRM,YSHFS,YSMODE,YSIO) ; -- open WORKSTATION device
+1 ; YSRM: right margin
+2 ; YSHFS: host file name
+3 ; YSMODE: open file in 'R'ead or 'W'rite mode
+4 SET ZTQUEUED=""
KILL IOPAR
+5 SET IOP="OR WORKSTATION;"_$GET(YSRM,80)_";66"
+6 SET %ZIS("HFSMODE")=YSMODE
SET %ZIS("HFSNAME")=YSHFS
+7 DO ^%ZIS
+8 KILL IOP,%ZIS
+9 USE IO
+10 SET YSIO=IO
+11 QUIT
+12 ;
CLOSE(YSRM,YSHFS,YSSUB,YSIO) ; -- close WORKSTATION device
+1 ; YSSUB: unique subscript name for output
+2 IF IO=YSIO
DO ^%ZISC
+3 USE IO
+4 DO USEHFS
+5 USE IO
+6 QUIT
USEHFS ; -- use host file to build global array
+1 NEW IO,YSOK,SECTION
+2 SET SECTION=0
+3 DO INIT
+4 SET YSOK=$$FTG^%ZISH(,YSHFS,$NAME(@ROOT@(1)),4)
IF 'YSOK
QUIT
+5 DO STRIP
+6 NEW YSARR
SET YSARR(YSHFS)=""
+7 SET YSOK=$$DEL^%ZISH("",$NAME(YSARR))
+8 QUIT
+9 ;
INIT ; -- initialize counts and global section
+1 SET (INC,CNT)=0
SET SECTION=SECTION+1
+2 SET ROOT=$NAME(^TMP(YSSUB,$JOB,SECTION))
+3 KILL @ROOT
+4 QUIT
+5 ;
STRIP ; -- strip off control chars
+1 NEW I,X
+2 SET I=0
FOR
SET I=$ORDER(@ROOT@(I))
if 'I
QUIT
SET X=^(I)
Begin DoDot:1
+3 ;BS
IF X[$CHAR(8)
Begin DoDot:2
+4 ;BS & _
IF $LENGTH(X,$CHAR(8))=$LENGTH(X,$CHAR(95))
SET (X,@ROOT@(I))=$TRANSLATE(X,$CHAR(8,95),"")
QUIT
+5 SET (X,@ROOT@(I))=$TRANSLATE(X,$CHAR(8),"")
End DoDot:2
+6 ;BEL or FF
IF X[$CHAR(7)!(X[$CHAR(12))
SET @ROOT@(I)=$TRANSLATE(X,$CHAR(7,12),"")
+7 ;asf 4/18/08
IF X[$CHAR(12)&(I>7)
SET @ROOT@(I+.5)="***eop***"_$CHAR(10)
End DoDot:1
+8 QUIT
+9 ;
TESTCODE(ROOT) ;YTRP LIST TEST/CODE
+1 NEW A
SET A="C"
+2 DO START(132,"ENP^YTLCTD")
+3 QUIT
TESTDES(ROOT) ;YTRP LIST TEST/DESC
+1 NEW A
SET A="D"
+2 DO START(132,"ENP^YTLCTD")
+3 QUIT
TESTTL(ROOT) ;YTRP LIST TEST/TITLE
+1 NEW A
SET A="T"
+2 DO START(132,"ENP^YTLCTD")
+3 QUIT
+4 ;
+5 ; Hrubovcak - 30 March 2012
+6 ;
AL60193 ; strip control chars. from all entries in MH REPORT (#601.93)
+1 ;
+2 DO DT^DICRW
+3 NEW YSI
SET YSI=0
+4 ; if W-P field exists
FOR
SET YSI=$ORDER(^YTT(601.93,YSI))
if '(YSI>0)
QUIT
if $ORDER(^YTT(601.93,YSI,1,0))
Begin DoDot:1
+5 ; exclusive access
LOCK +^YTT(601.93,YSI):DILOCKTM
IF '$TEST
QUIT
+6 DO RMVCC(YSI)
LOCK -^YTT(601.93,YSI)
End DoDot:1
+7 ;
+8 QUIT
+9 ;
RMVCC(YSIEN) ; remove control chars. from W-P field in MH REPORT (#601.93)
+1 ; entry should be LOCKed before call
+2 ; X=original, Y=fixed
NEW J,X,Y
+3 SET J=0
+4 FOR
SET J=$ORDER(^YTT(601.93,YSIEN,1,J))
if 'J
QUIT
SET X=$GET(^YTT(601.93,YSIEN,1,J,0))
IF X]""
SET Y=X
Begin DoDot:1
+5 ; indicates what was done
NEW FLAG
+6 ; backspace
IF Y[$CHAR(8)
Begin DoDot:2
+7 ; backspace & underscore
IF $LENGTH(Y,$CHAR(8))=$LENGTH(Y,$CHAR(95))
SET Y=$TRANSLATE(Y,$CHAR(8,95),"")
SET FLAG("BSUN")=1
QUIT
+8 ; backspace
SET Y=$TRANSLATE(Y,$CHAR(8),"")
SET FLAG("BS")=1
End DoDot:2
+9 ;
+10 ; bell or form feed
IF Y[$CHAR(7)!(Y[$CHAR(12))
if Y[$CHAR(12)
SET FLAG("FF")=1
if Y[$CHAR(7)
SET FLAG("BELL")=1
SET Y=$TRANSLATE(Y,$CHAR(7,12),"")
+11 ; no changes
if Y=X
QUIT
+12 SET ^YTT(601.93,YSIEN,1,J,0)=Y
+13 IF J>7
IF $GET(FLAG("FF"))
SET ^YTT(601.93,YSIEN,1,J+.5,0)="***eop***"_$CHAR(10)
End DoDot:1
+14 ;
+15 QUIT
+16 ;
