Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: YTQAPI5

YTQAPI5.m

Go to the documentation of this file.
  1. YTQAPI5 ;ALB/ASF - MHAX DISPLAYS ; 1/14/09 4:14pm
  1. ;;5.01;MENTAL HEALTH;**85,102,96,240**;Dec 30, 1994;Build 10
  1. ;
  1. ;
  1. ;Reference to ^DPT global (PATIENT - #2) supported by DBIA #10061
  1. ;Reference to XPDMENU API supported by DBIA #1157
  1. ;Reference to XQCHK API supported by DBIA #10078
  1. Q
  1. SURVDAT(YSDATA,YS) ;output survey type data
  1. N %DT,X,Y,YSAD,YSANSID,YSBEG,YSB,YSEND,YSLIMIT,YSN,YSQI,YSQID,YSQS
  1. 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
  1. S YSN=$O(^YTT(601.71,"B",YSCODE,0))
  1. S YSBEG=$G(YS("BEGIN")) S:YSBEG="" YSBEG="01/01/1970" S X=YSBEG,%DT="T" D ^%DT S YSBEG=Y
  1. S YSEND=$G(YS("END")) S:YSEND="" YSEND="01/01/2099" S X=YSEND,%DT="T" D ^%DT S YSEND=Y
  1. S YSLIMIT=$G(YS("LIMIT")) S:YSLIMIT="" YSLIMIT=999
  1. 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
  1. . Q:$P(^YTT(601.84,YSAD,0),U,9)'="Y" ;complete admins Only
  1. . W !,"AD= ",YSAD
  1. . S YSQS=0 F S YSQS=$O(^YTT(601.76,"AD",YSN,YSQS)) Q:YSQS'>0 D
  1. .. S YSQI=$O(^YTT(601.76,"AD",YSN,YSQS,0)) S YSQID=$P(^YTT(601.76,YSQI,0),U,4)
  1. .. W !,"QID= ",YSQID," QI= ",YSQI
  1. .. S YSANSID=$O(^YTT(601.85,"AC",YSAD,YSQID,0))
  1. .. Q:YSANSID=""
  1. .. W !,"Answer: ",^YTT(601.85,YSANSID,1,1,0)
  1. Q
  1. DISPLAY(YSDATA,YS) ;RETURN Display Info
  1. N N,N1,YSID
  1. S YSDATA(1)="[DATA]"
  1. S N=1,N1=0 F S N1=$O(YS(N1)) Q:N1'>0 D
  1. . S N=N+1
  1. . S YSID=YS(N1)
  1. . S YSDATA(N)=$$DISPEXT^YTQAPI5(YSID)
  1. . ;I '$D(^YTT(601.88,YSID,0)) S YSDATA(N)=YSID_U_"[ERROR] bad id" Q ;-->out
  1. .;S YSDATA(N)=^YTT(601.88,YSID,0)
  1. Q
  1. DISPEXT(YSID) ;EXTRINSIC 601.88
  1. N YSEX,I
  1. I '$D(^YTT(601.88,YSID,0)) S YSEX="[ERROR] BAD DISPLAY ID" Q YSEX
  1. S YSEX=YSID
  1. F I=1:1:11 S YSEX=YSEX_U_$$GET1^DIQ(601.88,YSID_",",I)
  1. Q YSEX
  1. ;
  1. ADMINS(YSDATA,YS) ;administration retrieval
  1. ;input : DFN
  1. ;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
  1. 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
  1. S DFN=$G(YS("DFN"))
  1. I DFN'?1N.NP S YSDATA(1)="[ERROR]",YSDATA(2)="bad DFN" Q ;-->out asf 2/22/08
  1. I '$D(^DPT(DFN,0)) S YSDATA(1)="[ERROR]",YSDATA(2)="no pt" Q ;-->out
  1. S YSINC=$G(YS("COMPLETE")) I (YSINC'="Y")&(YSINC'="N") S YSDATA(1)="[ERROR]",YSDATA(2)="bad complete flag" Q ;-->out
  1. S YSIENS=0,N=2
  1. S YSDATA(1)="[DATA]"
  1. F S YSIENS=$O(^YTT(601.84,"C",DFN,YSIENS)) Q:YSIENS'>0 D
  1. . S G=$G(^YTT(601.84,YSIENS,0))
  1. . I G="" S YSDATA(1)="[ERROR]",YSDATA(2)=YSIENS_" bad ien in 84" Q ;-->out
  1. . S YSISCOMP=$P(G,U,9)
  1. . Q:YSISCOMP'=YSINC
  1. . S YSDG=$P(G,U,4),YSCODE=$$GET1^DIQ(601.84,YSIENS_",",2)
  1. . Q:YSCODE=""
  1. . Q:'$D(^YTT(601.71,"B",YSCODE))
  1. . S YSCODIEN=$O(^YTT(601.71,"B",YSCODE,0))
  1. . S YSRPRIV=$$GET1^DIQ(601.71,YSCODIEN_",",9)
  1. . S YSREST=$$GET1^DIQ(601.71,YSCODIEN_",",27)
  1. . S YSCOPY=$P($G(^YTT(601.71,YSCODIEN,8)),U,5)
  1. . S YSLOCAT=$P($G(^YTT(601.84,YSIENS,0)),U,11)
  1. . S YSSRC=$P($G(^YTT(601.84,YSIENS,0)),U,13) I YSSRC S YSSRC=$P($G(^YTT(601.844,+YSSRC,0)),U)
  1. . S YSLEG=$P($G(^YTT(601.71,YSCODIEN,8)),U,3)
  1. . S YSLEGI="" S:YSLEG="Y" YSLEGI=$O(^YTT(601,"B",YSCODE,0))
  1. . 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
  1. . F Q:'$D(YSX(YSDG,YSCODE)) S YSDG=YSDG+.00000001 ;ASF 1/14/09
  1. . S YSX(YSDG,YSCODE)=YSX
  1. . S YSX1(YSCODE,YSDG)=""
  1. D:YSINC="Y" LISTALL
  1. D:YSINC="N" LISTINC
  1. D SET
  1. Q
  1. SET ;
  1. 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)
  1. S YSDATA(1)="[DATA]",YSDATA(2)=N-2_" administrations returned"
  1. Q
  1. LISTALL ;
  1. S N=0 F S N=$O(^YTD(601.2,DFN,1,N)) Q:N'>0 D
  1. . ;I $P(^YTT(601,N,0),U,9)="I" QUIT
  1. . I $D(^YTT(601,N)) S N2=0 F S N2=$O(^YTD(601.2,DFN,1,N,1,N2)) Q:N2'>0 D
  1. .. S X=^YTT(601,N,0),N4=$P(X,U)
  1. .. S YSCODIEN=$O(^YTT(601.71,"B",N4,0)) Q:YSCODIEN'>0 ;-->out
  1. .. S YSRPRIV=$$GET1^DIQ(601.71,YSCODIEN_",",9)
  1. .. S YSCOPY=$S($P(X,U,6)?1N.N:"Y",1:"N")
  1. .. Q:$P(X,U,9)'="T"
  1. .. Q:'$D(^YTD(601.2,DFN,1,N,1,N2,1))
  1. .. S G=$G(^YTD(601.2,DFN,1,N,1,N2,0))
  1. .. I N4="MMPI",$D(^YTD(601.2,DFN,1,N,1,N2,99)),^(99)="MMPIR" S N4="MMPR"
  1. .. 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
  1. .. Q
  1. Q
  1. 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
  1. S N1=0 F S N1=$O(^YTD(601.4,DFN,1,N1)) Q:N1'>0 D
  1. . S G=$G(^YTD(601.4,DFN,1,N1,0))
  1. . S YSCODE=$P($G(^YTT(601,N1,0)),U),YSDG=$P(G,U,2)
  1. . S YSCODEN=N1
  1. . S YSCOPY=$P(^YTT(601,N1,0),U,6) S YSCOPY=$S(+YSCOPY:"Y",1:"N")
  1. . I YSCODE?1"CLERK".E S YSCODEN=$P(G,U,6) S:YSCODEN>0 YSCODE=$P(^YTT(601,YSCODEN,0),U)
  1. . S YSCODIEN=$O(^YTT(601.71,"B",YSCODE,0)) Q:YSCODIEN'>0 ;-->out
  1. . S YSRPRIV=$$GET1^DIQ(601.71,YSCODIEN_",",9)
  1. . Q:$P(^YTT(601,YSCODEN,0),U,9)'="T"
  1. . S YSANSN=$P(G,U,4) S:YSANSN?1N.E YSANSN=YSANSN-1
  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
  1. Q
  1. DELADMIN(YSDATA,YS) ;delete an administration of a test ASF 1/14/09
  1. N DIK,YSAD,YSANS,YSRESUL,YSMENU,YSPRIV,YSEVDFN,YSEVTST,YSEVCPLT
  1. N DA
  1. S YSAD=$G(YS("AD"))
  1. I YSAD'?1N.N S YSDATA(1)="[ERROR]",YSDATA(2)="bad 601.84 IEN" Q ;-->out
  1. S YSMENU=$$LKOPT^XPDMENU("YSMANAGER")
  1. I YSMENU'>0 S YSDATA(1)="[ERROR]",YSDATA(2)="no ysmanager MENU" Q ;-->out
  1. S YSPRIV=$$ACCESS^XQCHK(DUZ,YSMENU)
  1. I YSPRIV'>0 S YSDATA(1)="[ERROR]",YSDATA(2)="no privilege" Q ;-->out
  1. S YSEVDFN=+$P($G(^YTT(601.84,+YSAD,0)),U,2)
  1. S YSEVTST=+$P($G(^YTT(601.84,+YSAD,0)),U,3)
  1. S YSEVTST=$P($G(^YTT(601.71,YSEVTST,0)),U)
  1. S YSEVCPLT=($P($G(^YTT(601.84,+YSAD,0)),U,9)="Y")
  1. S DIK="^YTT(601.84,",DA=YSAD D ^DIK
  1. S YSANS=0 F S YSANS=$O(^YTT(601.85,"AD",YSAD,YSANS)) Q:YSANS'>0 D
  1. . S DIK="^YTT(601.85,",DA=YSANS D ^DIK
  1. S YSRESUL=0 F S YSRESUL=$O(^YTT(601.92,"AC",YSAD,YSRESUL)) Q:YSRESUL'>0 D
  1. . S DIK="^YTT(601.92,",DA=YSRESUL D ^DIK
  1. S YSDATA(1)="[DATA]",YSDATA(2)=YSAD_" deleted"
  1. ; publish delete event for admin if it was completed
  1. I YSEVCPLT D DELETE^YTQEVNT(YSAD,YSEVDFN,YSEVTST,"windel")
  1. Q