YTQAPI5 ;ALB/ASF - MHAX DISPLAYS ; 1/14/09 4:14pm
;;5.01;MENTAL HEALTH;**85,102,96**;Dec 30, 1994;Build 46
;Reference to ^DPT global (PATIENT - #2) supported by DBIA #10061
;Reference to XPDMENU API supported by DBIA #1157
;Reference to XQCHK API supported by DBIA #10078
Q
SURVDAT(YSDATA,YS) ;output survey type data
N %DT,X,Y,YSAD,YSANSID,YSBEG,YSB,YSEND,YSLIMIT,YSN,YSQI,YSQID,YSQS
S YSCODE=$G(YS("CODE")) S:YSCODE="" YSCODE=0 I '$D(^YTT(601.71,"B",YSCODE)) S YSDATA(1)="[ERROR]",YSDATA(2)="bad tcode" Q ;-->out
S YSN=$O(^YTT(601.71,"B",YSCODE,0))
S YSBEG=$G(YS("BEGIN")) S:YSBEG="" YSBEG="01/01/1970" S X=YSBEG,%DT="T" D ^%DT S YSBEG=Y
S YSEND=$G(YS("END")) S:YSEND="" YSEND="01/01/2099" S X=YSEND,%DT="T" D ^%DT S YSEND=Y
S YSLIMIT=$G(YS("LIMIT")) S:YSLIMIT="" YSLIMIT=999
S YSB=0 F S YSB=$O(^YTT(601.84,"AC",YSN,YSB)) Q:YSB'>0 S YSAD=0 F S YSAD=$O(^YTT(601.84,"AC",YSN,YSB,YSAD)) Q:YSAD'>0 D
. Q:$P(^YTT(601.84,YSAD,0),U,9)'="Y" ;complete admins Only
. W !,"AD= ",YSAD
. S YSQS=0 F S YSQS=$O(^YTT(601.76,"AD",YSN,YSQS)) Q:YSQS'>0 D
.. S YSQI=$O(^YTT(601.76,"AD",YSN,YSQS,0)) S YSQID=$P(^YTT(601.76,YSQI,0),U,4)
.. W !,"QID= ",YSQID," QI= ",YSQI
.. S YSANSID=$O(^YTT(601.85,"AC",YSAD,YSQID,0))
.. Q:YSANSID=""
.. W !,"Answer: ",^YTT(601.85,YSANSID,1,1,0)
Q
DISPLAY(YSDATA,YS) ;RETURN Display Info
N N,N1,YSID
S YSDATA(1)="[DATA]"
S N=1,N1=0 F S N1=$O(YS(N1)) Q:N1'>0 D
. S N=N+1
. S YSID=YS(N1)
. S YSDATA(N)=$$DISPEXT^YTQAPI5(YSID)
. ;I '$D(^YTT(601.88,YSID,0)) S YSDATA(N)=YSID_U_"[ERROR] bad id" Q ;-->out
.;S YSDATA(N)=^YTT(601.88,YSID,0)
Q
DISPEXT(YSID) ;EXTRINSIC 601.88
N YSEX,I
I '$D(^YTT(601.88,YSID,0)) S YSEX="[ERROR] BAD DISPLAY ID" Q YSEX
S YSEX=YSID
F I=1:1:11 S YSEX=YSEX_U_$$GET1^DIQ(601.88,YSID_",",I)
Q YSEX
;
ADMINS(YSDATA,YS) ;administration retrieval
;input : DFN
;output:Adm. ID^Inst. Name^Date Given^Date Saved^Orderer^Admin.By^Signed^# Answers^R_Privl^Is Legacy^INSTRUMENT id^Test IENS^copyright^location iens^DAY RESTART
N N,N4,G,DFN,YSIENS,YSDG,YSCODE,YSRPRIV,YSEXEMP,YSCODIEN,YSINC,YSISCOMP,YSX,YSX1,YSCODEN,YSANSN,YSLEG,YSLEGI,N1,N2,YSCOPY,YSLOCAT,YSREST
S DFN=$G(YS("DFN"))
I DFN'?1N.NP S YSDATA(1)="[ERROR]",YSDATA(2)="bad DFN" Q ;-->out asf 2/22/08
I '$D(^DPT(DFN,0)) S YSDATA(1)="[ERROR]",YSDATA(2)="nO pt" Q ;-->out
S YSINC=$G(YS("COMPLETE")) I (YSINC'="Y")&(YSINC'="N") S YSDATA(1)="[ERROR]",YSDATA(2)="bad complete flag" Q ;-->out
S YSIENS=0,N=2
S YSDATA(1)="[DATA]"
F S YSIENS=$O(^YTT(601.84,"C",DFN,YSIENS)) Q:YSIENS'>0 D
. S G=$G(^YTT(601.84,YSIENS,0))
. I G="" S YSDATA(1)="[ERROR]",YSDATA(2)=YSIENS_" bad ien in 84" Q ;-->out
. S YSISCOMP=$P(G,U,9)
. Q:YSISCOMP'=YSINC
. S YSDG=$P(G,U,4),YSCODE=$$GET1^DIQ(601.84,YSIENS_",",2)
. Q:YSCODE=""
. Q:'$D(^YTT(601.71,"B",YSCODE))
. S YSCODIEN=$O(^YTT(601.71,"B",YSCODE,0))
. S YSRPRIV=$$GET1^DIQ(601.71,YSCODIEN_",",9)
. S YSREST=$$GET1^DIQ(601.71,YSCODIEN_",",27)
. S YSCOPY=$P($G(^YTT(601.71,YSCODIEN,8)),U,5)
. S YSLOCAT=$P($G(^YTT(601.84,YSIENS,0)),U,11)
. S YSLEG=$P($G(^YTT(601.71,YSCODIEN,8)),U,3)
. S YSLEGI="" S:YSLEG="Y" YSLEGI=$O(^YTT(601,"B",YSCODE,0))
. S YSX=YSIENS_U_YSCODE_U_YSDG_U_$P(G,U,5,8)_U_$P(G,U,10)_U_YSRPRIV_U_YSLEG_U_YSCODIEN_U_YSLEGI_U_YSCOPY_U_YSLOCAT_U_YSREST
. F Q:'$D(YSX(YSDG,YSCODE)) S YSDG=YSDG+.00000001 ;ASF 1/14/09
. S YSX(YSDG,YSCODE)=YSX
. S YSX1(YSCODE,YSDG)=""
D:YSINC="Y" LISTALL
D:YSINC="N" LISTINC
D SET
Q
SET ;
S N=2,N1=9999999 F S N1=$O(YSX(N1),-1) Q:N1="" S YSCODE="" F S YSCODE=$O(YSX(N1,YSCODE)) Q:YSCODE="" S N=N+1,YSDATA(N)=YSX(N1,YSCODE)
S YSDATA(1)="[DATA]",YSDATA(2)=N-2_" administrations returned"
Q
LISTALL ;
S N=0 F S N=$O(^YTD(601.2,DFN,1,N)) Q:N'>0 D
. ;I $P(^YTT(601,N,0),U,9)="I" QUIT
. I $D(^YTT(601,N)) S N2=0 F S N2=$O(^YTD(601.2,DFN,1,N,1,N2)) Q:N2'>0 D
.. S X=^YTT(601,N,0),N4=$P(X,U)
.. S YSCODIEN=$O(^YTT(601.71,"B",N4,0)) Q:YSCODIEN'>0 ;-->out
.. S YSRPRIV=$$GET1^DIQ(601.71,YSCODIEN_",",9)
.. S YSCOPY=$S($P(X,U,6)?1N.N:"Y",1:"N")
.. Q:$P(X,U,9)'="T"
.. Q:'$D(^YTD(601.2,DFN,1,N,1,N2,1))
.. S G=$G(^YTD(601.2,DFN,1,N,1,N2,0))
.. I N4="MMPI",$D(^YTD(601.2,DFN,1,N,1,N2,99)),^(99)="MMPIR" S N4="MMPR"
.. S YSX(N2,N4)=U_N4_U_$S($P(G,U,8)?7N.E:$P(G,U,8),1:N2)_U_N2_U_$P(G,U,3,4)_U_U_U_YSRPRIV_U_"Y"_U_U_N_U_YSCOPY_U ;ASF 12/19/06
.. Q
Q
LISTINC ;list all incompletes for a pt
;output:Adm. ID1^Inst. Name2^Date Given3^Date Saved4^Orderer5^Admin.By6^Signed7^# Answers8^R_Privl9^Is Legacy10^INSTRUMENT id11^Test IENS12^is COPY
S N1=0 F S N1=$O(^YTD(601.4,DFN,1,N1)) Q:N1'>0 D
. S G=$G(^YTD(601.4,DFN,1,N1,0))
. S YSCODE=$P($G(^YTT(601,N1,0)),U),YSDG=$P(G,U,2)
. S YSCODEN=N1
. S YSCOPY=$P(^YTT(601,N1,0),U,6) S YSCOPY=$S(+YSCOPY:"Y",1:"N")
. I YSCODE?1"CLERK".E S YSCODEN=$P(G,U,6) S:YSCODEN>0 YSCODE=$P(^YTT(601,YSCODEN,0),U)
. S YSCODIEN=$O(^YTT(601.71,"B",YSCODE,0)) Q:YSCODIEN'>0 ;-->out
. S YSRPRIV=$$GET1^DIQ(601.71,YSCODIEN_",",9)
. Q:$P(^YTT(601,YSCODEN,0),U,9)'="T"
. S YSANSN=$P(G,U,4) S:YSANSN?1N.E YSANSN=YSANSN-1
. S YSX(YSDG,YSCODE)=U_YSCODE_U_YSDG_U_$P(G,U,8)_U_$P(G,U,7)_U_U_U_YSANSN_U_YSRPRIV_U_"Y"_U_U_YSCODEN_U_YSCOPY_U
Q
DELADMIN(YSDATA,YS) ;delete an administration of a test ASF 1/14/09
N DIK,YSAD,YSANS,YSRESUL,YSMENU,YSPRIV
S YSAD=$G(YS("AD"))
I YSAD'?1N.N S YSDATA(1)="[ERROR]",YSDATA(2)="bad 601.84 IEN" Q ;-->out
S YSMENU=$$LKOPT^XPDMENU("YSMANAGER")
I YSMENU'>0 S YSDATA(1)="[ERROR]",YSDATA(2)="no ysmanager MENU" Q ;-->out
S YSPRIV=$$ACCESS^XQCHK(DUZ,YSMENU)
I YSPRIV'>0 S YSDATA(1)="[ERROR]",YSDATA(2)="no privilege" Q ;-->out
S DIK="^YTT(601.84,",DA=YSAD D ^DIK
S YSANS=0 F S YSANS=$O(^YTT(601.85,"AD",YSAD,YSANS)) Q:YSANS'>0 D
. S DIK="^YTT(601.85,",DA=YSANS D ^DIK
S YSRESUL=0 F S YSRESUL=$O(^YTT(601.92,"AC",YSAD,YSRESUL)) Q:YSRESUL'>0 D
. S DIK="^YTT(601.92,",DA=YSRESUL D ^DIK
S YSDATA(1)="[DATA]",YSDATA(2)=YSAD_" deleted"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQAPI5 5986 printed Oct 16, 2024@18:19:02 Page 2
YTQAPI5 ;ALB/ASF - MHAX DISPLAYS ; 1/14/09 4:14pm
+1 ;;5.01;MENTAL HEALTH;**85,102,96**;Dec 30, 1994;Build 46
+2 ;Reference to ^DPT global (PATIENT - #2) supported by DBIA #10061
+3 ;Reference to XPDMENU API supported by DBIA #1157
+4 ;Reference to XQCHK API supported by DBIA #10078
+5 QUIT
SURVDAT(YSDATA,YS) ;output survey type data
+1 NEW %DT,X,Y,YSAD,YSANSID,YSBEG,YSB,YSEND,YSLIMIT,YSN,YSQI,YSQID,YSQS
+2 ;-->out
SET YSCODE=$GET(YS("CODE"))
if YSCODE=""
SET YSCODE=0
IF '$DATA(^YTT(601.71,"B",YSCODE))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad tcode"
QUIT
+3 SET YSN=$ORDER(^YTT(601.71,"B",YSCODE,0))
+4 SET YSBEG=$GET(YS("BEGIN"))
if YSBEG=""
SET YSBEG="01/01/1970"
SET X=YSBEG
SET %DT="T"
DO ^%DT
SET YSBEG=Y
+5 SET YSEND=$GET(YS("END"))
if YSEND=""
SET YSEND="01/01/2099"
SET X=YSEND
SET %DT="T"
DO ^%DT
SET YSEND=Y
+6 SET YSLIMIT=$GET(YS("LIMIT"))
if YSLIMIT=""
SET YSLIMIT=999
+7 SET YSB=0
FOR
SET YSB=$ORDER(^YTT(601.84,"AC",YSN,YSB))
if YSB'>0
QUIT
SET YSAD=0
FOR
SET YSAD=$ORDER(^YTT(601.84,"AC",YSN,YSB,YSAD))
if YSAD'>0
QUIT
Begin DoDot:1
+8 ;complete admins Only
if $PIECE(^YTT(601.84,YSAD,0),U,9)'="Y"
QUIT
+9 WRITE !,"AD= ",YSAD
+10 SET YSQS=0
FOR
SET YSQS=$ORDER(^YTT(601.76,"AD",YSN,YSQS))
if YSQS'>0
QUIT
Begin DoDot:2
+11 SET YSQI=$ORDER(^YTT(601.76,"AD",YSN,YSQS,0))
SET YSQID=$PIECE(^YTT(601.76,YSQI,0),U,4)
+12 WRITE !,"QID= ",YSQID," QI= ",YSQI
+13 SET YSANSID=$ORDER(^YTT(601.85,"AC",YSAD,YSQID,0))
+14 if YSANSID=""
QUIT
+15 WRITE !,"Answer: ",^YTT(601.85,YSANSID,1,1,0)
End DoDot:2
End DoDot:1
+16 QUIT
DISPLAY(YSDATA,YS) ;RETURN Display Info
+1 NEW N,N1,YSID
+2 SET YSDATA(1)="[DATA]"
+3 SET N=1
SET N1=0
FOR
SET N1=$ORDER(YS(N1))
if N1'>0
QUIT
Begin DoDot:1
+4 SET N=N+1
+5 SET YSID=YS(N1)
+6 SET YSDATA(N)=$$DISPEXT^YTQAPI5(YSID)
+7 ;I '$D(^YTT(601.88,YSID,0)) S YSDATA(N)=YSID_U_"[ERROR] bad id" Q ;-->out
+8 ;S YSDATA(N)=^YTT(601.88,YSID,0)
End DoDot:1
+9 QUIT
DISPEXT(YSID) ;EXTRINSIC 601.88
+1 NEW YSEX,I
+2 IF '$DATA(^YTT(601.88,YSID,0))
SET YSEX="[ERROR] BAD DISPLAY ID"
QUIT YSEX
+3 SET YSEX=YSID
+4 FOR I=1:1:11
SET YSEX=YSEX_U_$$GET1^DIQ(601.88,YSID_",",I)
+5 QUIT YSEX
+6 ;
ADMINS(YSDATA,YS) ;administration retrieval
+1 ;input : DFN
+2 ;output:Adm. ID^Inst. Name^Date Given^Date Saved^Orderer^Admin.By^Signed^# Answers^R_Privl^Is Legacy^INSTRUMENT id^Test IENS^copyright^location iens^DAY RESTART
+3 NEW N,N4,G,DFN,YSIENS,YSDG,YSCODE,YSRPRIV,YSEXEMP,YSCODIEN,YSINC,YSISCOMP,YSX,YSX1,YSCODEN,YSANSN,YSLEG,YSLEGI,N1,N2,YSCOPY,YSLOCAT,YSREST
+4 SET DFN=$GET(YS("DFN"))
+5 ;-->out asf 2/22/08
IF DFN'?1N.NP
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad DFN"
QUIT
+6 ;-->out
IF '$DATA(^DPT(DFN,0))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="nO pt"
QUIT
+7 ;-->out
SET YSINC=$GET(YS("COMPLETE"))
IF (YSINC'="Y")&(YSINC'="N")
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad complete flag"
QUIT
+8 SET YSIENS=0
SET N=2
+9 SET YSDATA(1)="[DATA]"
+10 FOR
SET YSIENS=$ORDER(^YTT(601.84,"C",DFN,YSIENS))
if YSIENS'>0
QUIT
Begin DoDot:1
+11 SET G=$GET(^YTT(601.84,YSIENS,0))
+12 ;-->out
IF G=""
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)=YSIENS_" bad ien in 84"
QUIT
+13 SET YSISCOMP=$PIECE(G,U,9)
+14 if YSISCOMP'=YSINC
QUIT
+15 SET YSDG=$PIECE(G,U,4)
SET YSCODE=$$GET1^DIQ(601.84,YSIENS_",",2)
+16 if YSCODE=""
QUIT
+17 if '$DATA(^YTT(601.71,"B",YSCODE))
QUIT
+18 SET YSCODIEN=$ORDER(^YTT(601.71,"B",YSCODE,0))
+19 SET YSRPRIV=$$GET1^DIQ(601.71,YSCODIEN_",",9)
+20 SET YSREST=$$GET1^DIQ(601.71,YSCODIEN_",",27)
+21 SET YSCOPY=$PIECE($GET(^YTT(601.71,YSCODIEN,8)),U,5)
+22 SET YSLOCAT=$PIECE($GET(^YTT(601.84,YSIENS,0)),U,11)
+23 SET YSLEG=$PIECE($GET(^YTT(601.71,YSCODIEN,8)),U,3)
+24 SET YSLEGI=""
if YSLEG="Y"
SET YSLEGI=$ORDER(^YTT(601,"B",YSCODE,0))
+25 SET YSX=YSIENS_U_YSCODE_U_YSDG_U_$PIECE(G,U,5,8)_U_$PIECE(G,U,10)_U_YSRPRIV_U_YSLEG_U_YSCODIEN_U_YSLEGI_U_YSCOPY_U_YSLOCAT_U_YSREST
+26 ;ASF 1/14/09
FOR
if '$DATA(YSX(YSDG,YSCODE))
QUIT
SET YSDG=YSDG+.00000001
+27 SET YSX(YSDG,YSCODE)=YSX
+28 SET YSX1(YSCODE,YSDG)=""
End DoDot:1
+29 if YSINC="Y"
DO LISTALL
+30 if YSINC="N"
DO LISTINC
+31 DO SET
+32 QUIT
SET ;
+1 SET N=2
SET N1=9999999
FOR
SET N1=$ORDER(YSX(N1),-1)
if N1=""
QUIT
SET YSCODE=""
FOR
SET YSCODE=$ORDER(YSX(N1,YSCODE))
if YSCODE=""
QUIT
SET N=N+1
SET YSDATA(N)=YSX(N1,YSCODE)
+2 SET YSDATA(1)="[DATA]"
SET YSDATA(2)=N-2_" administrations returned"
+3 QUIT
LISTALL ;
+1 SET N=0
FOR
SET N=$ORDER(^YTD(601.2,DFN,1,N))
if N'>0
QUIT
Begin DoDot:1
+2 ;I $P(^YTT(601,N,0),U,9)="I" QUIT
+3 IF $DATA(^YTT(601,N))
SET N2=0
FOR
SET N2=$ORDER(^YTD(601.2,DFN,1,N,1,N2))
if N2'>0
QUIT
Begin DoDot:2
+4 SET X=^YTT(601,N,0)
SET N4=$PIECE(X,U)
+5 ;-->out
SET YSCODIEN=$ORDER(^YTT(601.71,"B",N4,0))
if YSCODIEN'>0
QUIT
+6 SET YSRPRIV=$$GET1^DIQ(601.71,YSCODIEN_",",9)
+7 SET YSCOPY=$SELECT($PIECE(X,U,6)?1N.N:"Y",1:"N")
+8 if $PIECE(X,U,9)'="T"
QUIT
+9 if '$DATA(^YTD(601.2,DFN,1,N,1,N2,1))
QUIT
+10 SET G=$GET(^YTD(601.2,DFN,1,N,1,N2,0))
+11 IF N4="MMPI"
IF $DATA(^YTD(601.2,DFN,1,N,1,N2,99))
IF ^(99)="MMPIR"
SET N4="MMPR"
+12 ;ASF 12/19/06
SET YSX(N2,N4)=U_N4_U_$SELECT($PIECE(G,U,8)?7N.E:$PIECE(G,U,8),1:N2)_U_N2_U_$PIECE(G,U,3,4)_U_U_U_YSRPRIV_U_"Y"_U_U_N_U_YSCOPY_U
+13 QUIT
End DoDot:2
End DoDot:1
+14 QUIT
LISTINC ;list all incompletes for a pt
+1 ;output:Adm. ID1^Inst. Name2^Date Given3^Date Saved4^Orderer5^Admin.By6^Signed7^# Answers8^R_Privl9^Is Legacy10^INSTRUMENT id11^Test IENS12^is COPY
+2 SET N1=0
FOR
SET N1=$ORDER(^YTD(601.4,DFN,1,N1))
if N1'>0
QUIT
Begin DoDot:1
+3 SET G=$GET(^YTD(601.4,DFN,1,N1,0))
+4 SET YSCODE=$PIECE($GET(^YTT(601,N1,0)),U)
SET YSDG=$PIECE(G,U,2)
+5 SET YSCODEN=N1
+6 SET YSCOPY=$PIECE(^YTT(601,N1,0),U,6)
SET YSCOPY=$SELECT(+YSCOPY:"Y",1:"N")
+7 IF YSCODE?1"CLERK".E
SET YSCODEN=$PIECE(G,U,6)
if YSCODEN>0
SET YSCODE=$PIECE(^YTT(601,YSCODEN,0),U)
+8 ;-->out
SET YSCODIEN=$ORDER(^YTT(601.71,"B",YSCODE,0))
if YSCODIEN'>0
QUIT
+9 SET YSRPRIV=$$GET1^DIQ(601.71,YSCODIEN_",",9)
+10 if $PIECE(^YTT(601,YSCODEN,0),U,9)'="T"
QUIT
+11 SET YSANSN=$PIECE(G,U,4)
if YSANSN?1N.E
SET YSANSN=YSANSN-1
+12 SET YSX(YSDG,YSCODE)=U_YSCODE_U_YSDG_U_$PIECE(G,U,8)_U_$PIECE(G,U,7)_U_U_U_YSANSN_U_YSRPRIV_U_"Y"_U_U_YSCODEN_U_YSCOPY_U
End DoDot:1
+13 QUIT
DELADMIN(YSDATA,YS) ;delete an administration of a test ASF 1/14/09
+1 NEW DIK,YSAD,YSANS,YSRESUL,YSMENU,YSPRIV
+2 SET YSAD=$GET(YS("AD"))
+3 ;-->out
IF YSAD'?1N.N
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad 601.84 IEN"
QUIT
+4 SET YSMENU=$$LKOPT^XPDMENU("YSMANAGER")
+5 ;-->out
IF YSMENU'>0
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no ysmanager MENU"
QUIT
+6 SET YSPRIV=$$ACCESS^XQCHK(DUZ,YSMENU)
+7 ;-->out
IF YSPRIV'>0
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no privilege"
QUIT
+8 SET DIK="^YTT(601.84,"
SET DA=YSAD
DO ^DIK
+9 SET YSANS=0
FOR
SET YSANS=$ORDER(^YTT(601.85,"AD",YSAD,YSANS))
if YSANS'>0
QUIT
Begin DoDot:1
+10 SET DIK="^YTT(601.85,"
SET DA=YSANS
DO ^DIK
End DoDot:1
+11 SET YSRESUL=0
FOR
SET YSRESUL=$ORDER(^YTT(601.92,"AC",YSAD,YSRESUL))
if YSRESUL'>0
QUIT
Begin DoDot:1
+12 SET DIK="^YTT(601.92,"
SET DA=YSRESUL
DO ^DIK
End DoDot:1
+13 SET YSDATA(1)="[DATA]"
SET YSDATA(2)=YSAD_" deleted"
+14 QUIT
