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

YTQAPI11.m

Go to the documentation of this file.
  1. YTQAPI11 ;ASF/ALB - MHAx API ; 8/9/10 10:34am
  1. ;;5.01;MENTAL HEALTH;**85,96,123,187**;DEC 30,1994;Build 73
  1. ;
  1. ;Reference to %ZIS supported by IA #10086
  1. ;Reference to %ZTLOAD supported by IA #10063
  1. ;Reference to DOB^DPTLK1 supported by IA #3266
  1. ;Reference to SSN^DPTLK1 supported by IA #3267
  1. SCORSAVE(YSDATA,YS) ;save results to 601.92
  1. ; input: AD as administration ID
  1. ; output: DATA vs ERROR
  1. N YSAD,DIK,YSG,YSRNEW ; patch 123: don't need, removed tasking,Z,ZTRTN,ZTIO,ZTSAVE,ZTDESC,ZTDTH
  1. ; patch 123, new variables
  1. N DA,Z
  1. S YSAD=$G(YS("AD"))
  1. I YSAD'?1N.N S YSDATA(1)="[ERROR]",YSDATA(2)="bad ad num" Q ;-->out
  1. I '$D(^YTT(601.84,YSAD)) S YSDATA(1)="[ERROR]",YSDATA(2)="ad not found" Q ;-->out
  1. ;
  1. S YSDATA(1)="[DATA]"
  1. ;task
  1. ; patch 123 -- remove tasking call
  1. ;D D ^%ZTLOAD D HOME^%ZIS K IO("Q") Q ;-->out
  1. ;.S ZTIO="",ZTDTH=$H
  1. ;.S ZTRTN="SSEN^YTQAPI11",ZTDESC="MHA3 SCORSAVE",ZTSAVE("YS*")=""
  1. ;
  1. SSEN ;scorsave entry
  1. ; patch 123 remove this, put in 2 other calls.
  1. ;D GETSCORE^YTQAPI8(.YSDATA,.YS)
  1. ; new subroutines
  1. D LOADANSW^YTSCORE(.YSDATA,.YS) ; put Answers for an Admin into YSDATA
  1. N IEN71
  1. S IEN71=$$GET1^DIQ(601.84,YSAD_",",2,"I")
  1. I 'IEN71 S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="No Instrument IEN in SCORSAVE" Q ;-->out
  1. ; design is in doScoring logic document
  1. D SCOREINS^YTSCORE(.YSDATA,.IEN71) ; score the instrument passing Answer Array (YSDATA) and Instrument IEN
  1. I $G(^TMP($J,"YSCOR",1))'="[DATA]" S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="Scoring Error, in SCORSAVE" Q ;-->out
  1. D UPDSCORE^YTSCORE(.YSDATA,.YS)
  1. Q
  1. ;delete any previous scores for this admin
  1. ; patch 123, original code, no longer deleting scores
  1. ;S DIK="^YTT(601.92,",DA=0
  1. ;F S DA=$O(^YTT(601.92,"AC",YSAD,DA)) Q:DA'>0 D ^DIK
  1. ;ADD SCORES
  1. ;S Z=1 F S Z=$O(^TMP($J,"YSCOR",Z)) Q:Z'>0 D
  1. ;. S YSG=^TMP($J,"YSCOR",Z)
  1. ;. S YSRNEW=$$NEW^YTQLIB(601.92)
  1. ;. S ^YTT(601.92,YSRNEW,0)=YSRNEW_U_YSAD_U_$P(YSG,"=")_U_$P(YSG,"=",2)
  1. ;. S DA=YSRNEW D IX^DIK
  1. ;S YSDATA(1)="[DATA]"
  1. ;Q
  1. SCALES ;from copy
  1. S YSSGOLD="" F S YSSGOLD=$O(^YTT(601.86,"AD",YSOLDNUM,YSSGOLD)) Q:YSSGOLD'>0 D
  1. . S YSSGNEW=$$NEW^YTQLIB(601.86)
  1. . S ^YTT(601.86,YSSGNEW,0)=^YTT(601.86,YSSGOLD,0)
  1. . S $P(^YTT(601.86,YSSGNEW,0),U)=YSSGNEW
  1. . S $P(^YTT(601.86,YSSGNEW,0),U,2)=YSNEWNUM
  1. . S DA=YSSGNEW,DIK="^YTT(601.86," D IX^DIK
  1. . S YSSLOLD=0 F S YSSLOLD=$O(^YTT(601.87,"AD",YSSGOLD,YSSLOLD)) Q:YSSLOLD'>0 D
  1. .. S YSSLNEW=$$NEW^YTQLIB(601.87)
  1. .. S ^YTT(601.87,YSSLNEW,0)=^YTT(601.87,YSSLOLD,0)
  1. .. S $P(^YTT(601.87,YSSLNEW,0),U)=YSSLNEW
  1. .. S $P(^YTT(601.87,YSSLNEW,0),U,2)=YSSGNEW
  1. .. S DA=YSSLNEW,DIK="^YTT(601.87," D IX^DIK
  1. .. S YSKEYOLD=0 F S YSKEYOLD=$O(^YTT(601.91,"AC",YSSLOLD,YSKEYOLD)) Q:YSKEYOLD'>0 D
  1. ... S YSKEYNEW=$$NEW^YTQLIB(601.91)
  1. ... S ^YTT(601.91,YSKEYNEW,0)=^YTT(601.91,YSKEYOLD,0)
  1. ... S $P(^YTT(601.91,YSKEYNEW,0),U)=YSKEYNEW
  1. ... S $P(^YTT(601.91,YSKEYNEW,0),U,2)=YSSLNEW
  1. ... S YSQX=$P(^YTT(601.91,YSKEYNEW,0),U,3)
  1. ... I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.91,YSKEYNEW,0),U,3)=^TMP($J,"YSM","O",YSQX)
  1. ... S DA=YSKEYNEW,DIK="^YTT(601.91," D IX^DIK
  1. Q
  1. RULES ;from copy
  1. S N=$O(^YTT(601.83,"C",YSOLDNUM,N)) Q:N'>0 D
  1. . S G1=^YTT(601.83,N,0)
  1. . S YSISRNEW=$$NEW^YTQLIB(YSFILE)
  1. . S ^YTT(601.83,YSISRNEW,0)=G1
  1. . S $P(^YTT(601.83,YSISRNEW,0),U)=YSISRNEW
  1. . S $P(^YTT(601.83,YSISRNEW,0),U,2)=YSNEWNUM
  1. . S YSQX=$P(G1,U,3)
  1. . I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.83,YSECNEW,0),U,3)=^TMP($J,"YSM","O",YSQX)
  1. . S DA=YSISRNEW,DIK="^YTT("_YSFILE_"," D IX^DIK
  1. . ;add rule
  1. . S YSRULOLD=$P(G,U,4)
  1. . S G2=^YTT(601.82,YSRULOLD,0)
  1. . S YSRULNEW=$$NEW^YTQLIB(601.82)
  1. . S $P(^YTT(601.83,YSISRNEW,0),U,4)=YSRULNEW
  1. . S ^YTT(601.82,YSRULNEW,0)=G2
  1. . S $P(^YTT(601.82,YSRULNEW,0),U)=YSRULNEW
  1. . S YSQX=$P(G2,U,2)
  1. . I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.82,YSRULNEW,0),U,2)=^TMP($J,"YSM","O",YSQX)
  1. . S YSQX=$P(G2,U,7)
  1. . I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.82,YSRULNEW,0),U,7)=^TMP($J,"YSM","O",YSQX)
  1. . S DA=YSRULNEW,DIK="^YTT(601.82," D IX^DIK
  1. Q
  1. FULLWP(YSDATA,YS) ;first line of all WPS
  1. ;returns a WP field
  1. ;Input: FILEN(file number), FIELD (WP filed #)
  1. ;Ouput IEN^WP Text line N
  1. N N,YSN,YSN1,YSFILEN,YSFIELD
  1. S YSDATA=$NA(^TMP($J,"YSWP")) K ^TMP($J,"YSWP")
  1. S YSFILEN=$G(YS("FILEN"),0) I $$VFILE^DILFD(YSFILEN)<1 S ^TMP($J,"YSWP",1)="[ERROR]",^TMP($J,"YSWP",2)="BAD FILE N" Q ;--->out
  1. S YSFIELD=$G(YS("FIELD"),0) S N=$$VFIELD^DILFD(YSFILEN,YSFIELD) I N<1 S ^TMP($J,"YSWP",1)="[ERROR]",^TMP($J,"YSWP",2)="BAD field" Q ;--> out
  1. S YSN=0,N=1,^TMP($J,"YSWP",1)="[DATA]"
  1. F S YSN=$O(^YTT(YSFILEN,YSN)) Q:YSN'>0 D
  1. . S YSN1=0 F S YSN1=$O(^YTT(YSFILEN,YSN,YSFIELD,YSN1)) Q:YSN1'>0 D
  1. .. S N=N+1
  1. .. S ^TMP($J,"YSWP",N)=YSN_U_$G(^YTT(YSFILEN,YSN,YSFIELD,YSN1,0))
  1. Q
  1. FINDP(YSDATA,YS) ; patient lookup
  1. ; input:
  1. ; VALUE = value to lookup
  1. ; NUMBER= maximum number to find
  1. ; Lookup uses multiple index lookup of File #2
  1. ; output:
  1. ; [DATA]^number of records returned
  1. ; DFN^patient name^DOB^PID^Gender
  1. ;
  1. N DIERR,YSVALUE,NODE,SSN,DSSN,PLID,YSN,YSX,YSNUMBER
  1. S YSVALUE=$G(YS("VALUE"))
  1. S YSNUMBER=$G(YS("NUMBER"),"*")
  1. K ^TMP("YSDATA",$J) S YSDATA=$NA(^TMP("YSDATA",$J))
  1. D FIND^DIC(2,,".01;.03;.363;.09;.02","PS",YSVALUE,YSNUMBER,"B^BS^BS5^SSN")
  1. I $G(DIERR) D CLEAN^DILF Q
  1. S YSN=1,^TMP("YSDATA",$J,YSN)="[DATA]"_U_+^TMP("DILIST",$J,0)
  1. S YSX=0 F S YSX=$O(^TMP("DILIST",$J,YSX)) Q:YSX'>0 D
  1. . S NODE=^TMP("DILIST",$J,YSX,0)
  1. . ;Apply DOB screen
  1. . S $P(NODE,U,3)=$$DOB^DPTLK1(+NODE)
  1. . ;Apply SSN screen
  1. . S SSN=$$SSN^DPTLK1(+NODE)
  1. . ;S DSSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,11)
  1. . S DSSN="xxx-xx-"_$E(SSN,6,11)
  1. . S PLID=$P(NODE,U,4)
  1. . I $E(SSN,1,9)'?9N S (DSSN,PLID)=SSN
  1. . S $P(NODE,U,4)=$S($L(PLID)>5:PLID,1:DSSN)
  1. . ;Move screened data back into output global
  1. . S YSN=YSN+1,^TMP("YSDATA",$J,YSN)=$P(NODE,U,1,4)_U_$P(NODE,U,6)
  1. K ^TMP("DILIST",$J)
  1. Q