- YTQAPI5 ;ALB/ASF - MHAX DISPLAYS ; 1/14/09 4:14pm
- ;;5.01;MENTAL HEALTH;**85,102,96,240**;Dec 30, 1994;Build 10
- ;
- ;
- ;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^SOURCE
- N N,N4,G,DFN,YSIENS,YSDG,YSCODE,YSRPRIV,YSEXEMP,YSCODIEN,YSINC,YSISCOMP,YSX,YSX1,YSCODEN,YSANSN,YSLEG,YSLEGI,N1,N2,YSCOPY,YSLOCAT,YSREST,YSSRC
- 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 YSSRC=$P($G(^YTT(601.84,YSIENS,0)),U,13) I YSSRC S YSSRC=$P($G(^YTT(601.844,+YSSRC,0)),U)
- . 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_U_YSSRC
- . 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,YSEVDFN,YSEVTST,YSEVCPLT
- N DA
- 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 YSEVDFN=+$P($G(^YTT(601.84,+YSAD,0)),U,2)
- S YSEVTST=+$P($G(^YTT(601.84,+YSAD,0)),U,3)
- S YSEVTST=$P($G(^YTT(601.71,YSEVTST,0)),U)
- S YSEVCPLT=($P($G(^YTT(601.84,+YSAD,0)),U,9)="Y")
- 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"
- ; publish delete event for admin if it was completed
- I YSEVCPLT D DELETE^YTQEVNT(YSAD,YSEVDFN,YSEVTST,"windel")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQAPI5 6452 printed Jan 18, 2025@03:19:27 Page 2
- YTQAPI5 ;ALB/ASF - MHAX DISPLAYS ; 1/14/09 4:14pm
- +1 ;;5.01;MENTAL HEALTH;**85,102,96,240**;Dec 30, 1994;Build 10
- +2 ;
- +3 ;
- +4 ;Reference to ^DPT global (PATIENT - #2) supported by DBIA #10061
- +5 ;Reference to XPDMENU API supported by DBIA #1157
- +6 ;Reference to XQCHK API supported by DBIA #10078
- +7 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^SOURCE
- +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,YSSRC
- +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 YSSRC=$PIECE($GET(^YTT(601.84,YSIENS,0)),U,13)
- IF YSSRC
- SET YSSRC=$PIECE($GET(^YTT(601.844,+YSSRC,0)),U)
- +24 SET YSLEG=$PIECE($GET(^YTT(601.71,YSCODIEN,8)),U,3)
- +25 SET YSLEGI=""
- if YSLEG="Y"
- SET YSLEGI=$ORDER(^YTT(601,"B",YSCODE,0))
- +26 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_U_YSSRC
- +27 ;ASF 1/14/09
- FOR
- if '$DATA(YSX(YSDG,YSCODE))
- QUIT
- SET YSDG=YSDG+.00000001
- +28 SET YSX(YSDG,YSCODE)=YSX
- +29 SET YSX1(YSCODE,YSDG)=""
- End DoDot:1
- +30 if YSINC="Y"
- DO LISTALL
- +31 if YSINC="N"
- DO LISTINC
- +32 DO SET
- +33 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,YSEVDFN,YSEVTST,YSEVCPLT
- +2 NEW DA
- +3 SET YSAD=$GET(YS("AD"))
- +4 ;-->out
- IF YSAD'?1N.N
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="bad 601.84 IEN"
- QUIT
- +5 SET YSMENU=$$LKOPT^XPDMENU("YSMANAGER")
- +6 ;-->out
- IF YSMENU'>0
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="no ysmanager MENU"
- QUIT
- +7 SET YSPRIV=$$ACCESS^XQCHK(DUZ,YSMENU)
- +8 ;-->out
- IF YSPRIV'>0
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="no privilege"
- QUIT
- +9 SET YSEVDFN=+$PIECE($GET(^YTT(601.84,+YSAD,0)),U,2)
- +10 SET YSEVTST=+$PIECE($GET(^YTT(601.84,+YSAD,0)),U,3)
- +11 SET YSEVTST=$PIECE($GET(^YTT(601.71,YSEVTST,0)),U)
- +12 SET YSEVCPLT=($PIECE($GET(^YTT(601.84,+YSAD,0)),U,9)="Y")
- +13 SET DIK="^YTT(601.84,"
- SET DA=YSAD
- DO ^DIK
- +14 SET YSANS=0
- FOR
- SET YSANS=$ORDER(^YTT(601.85,"AD",YSAD,YSANS))
- if YSANS'>0
- QUIT
- Begin DoDot:1
- +15 SET DIK="^YTT(601.85,"
- SET DA=YSANS
- DO ^DIK
- End DoDot:1
- +16 SET YSRESUL=0
- FOR
- SET YSRESUL=$ORDER(^YTT(601.92,"AC",YSAD,YSRESUL))
- if YSRESUL'>0
- QUIT
- Begin DoDot:1
- +17 SET DIK="^YTT(601.92,"
- SET DA=YSRESUL
- DO ^DIK
- End DoDot:1
- +18 SET YSDATA(1)="[DATA]"
- SET YSDATA(2)=YSAD_" deleted"
- +19 ; publish delete event for admin if it was completed
- +20 IF YSEVCPLT
- DO DELETE^YTQEVNT(YSAD,YSEVDFN,YSEVTST,"windel")
- +21 QUIT