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

YTQPXRM4.m

Go to the documentation of this file.
  1. YTQPXRM4 ;ASF/ALB - CLINICAL REMINDERS CONT ; 10/29/07 3:06pm
  1. ;;5.01;MENTAL HEALTH;**85,240**;DEC 30,1994;Build 10
  1. ;
  1. Q
  1. CHECKCR(YSDATA,YS) ;check out cr dialog is ok
  1. ; input: CODE,DFN,^TMP($J,AARAY,sequential)=ITEM#^RESPONSE
  1. ;output [DATA] VS [ERROR]
  1. ;scoring in ^TMP($J,"YSCOR"
  1. N DA,DFN,N,YSV,YSCODE,YSQNUMB,YSADDER,YSNEWA,YSADDER,YSDATAZ,YSANS,YSX,YSBOP1
  1. N YSERR,YSLEGA,YSRR,YSCHOT,YSCHOICE,G,YSLN,YSIC,YSQN,YSF,YSCODE,J,N83,YSANSIV,YSIV,YSQ1,YSRG,YSRULE,YSRULID,DIK,YS84IEN,J1,YSTESTN
  1. S DFN=$G(YS("DFN"),-1) I '$D(^DPT(DFN)) S YSDATA(1)="ERROR",YSDATA(2)="bad DFN" Q ;-->out
  1. S YSDATA(1)="[DATA]"
  1. D ALLIN
  1. Q:(YSDATA(1)'="[DATA]") ;-->out
  1. D SAVEOK
  1. N YSEVDFN,YSEVTST,YSEVCPLT
  1. S YSEVDFN=+$P($G(^YTT(601.84,+YS84IEN,0)),U,2)
  1. S YSEVTST=+$P($G(^YTT(601.84,+YS84IEN,0)),U,3)
  1. S YSEVTST=$P($G(^YTT(601.71,YSEVTST,0)),U)
  1. S YSEVCPLT=($P($G(^YTT(601.84,+YS84IEN,0)),U,9)="Y")
  1. L +^YTT(601.84,YS84IEN):30
  1. K YS D ANSSET
  1. D GETSCORE^YTQAPI8(.YSV,.YS)
  1. ; delete admin as it is not fully ok'd
  1. S J=0 F S J=$O(^YTT(601.85,"AC",YS84IEN,J)) Q:J'>0 S J1=0 F S J1=$O(^YTT(601.85,"AC",YS84IEN,J,J1)) Q:J1'>0 D
  1. . K DIK S DA=J1,DIK="^YTT(601.85," D ^DIK
  1. K DIK S DA=YS84IEN,DIK="^YTT(601.84," D ^DIK ;moved 10/29/07 asf
  1. L -^YTT(601.84,YS84IEN):30
  1. ; publish delete event for admin if it was completed
  1. I YSEVCPLT D DELETE^YTQEVNT(YS84IEN,YSEVDFN,YSEVTST,"crdel")
  1. K ^TMP($J,"YSQU")
  1. Q
  1. SAVECR(YSDATA,YS) ;save cr entered instruments
  1. ; input: CODE,DFN,^TMP($J,AARAY,sequential)=ITEM#^RESPONSE
  1. ;output [DATA] VS [ERROR]
  1. N DA,DFN,N,YSCODE,YSQNUMB,YSADDER,YSNEWA,YSADDER,YS84IEN,YSDATAZ,YSANS,YSX,YSBOP1,YSSTAFF,YSADATE
  1. N YSERR,YSLEGA,YSRR,YSCHOT,YSCHOICE,G,YSLN,YSIC,YSQN,YSF,YSCODE,J,N83,YSANSIV,YSIV,YSQ1,YSRG,YSRULE,YSRULID,J1,YSTESTN
  1. S DFN=$G(YS("DFN"),-1) I '$D(^DPT(DFN)) S YSDATA(1)="ERROR",YSDATA(2)="bad DFN" Q ;-->out
  1. S YSADATE=$G(YS("ADATE"),"NOW")
  1. S YSSTAFF=$G(YS("STAFF"),DUZ)
  1. S YSDATA(1)="[DATA]"
  1. D ALLIN
  1. Q:(YSDATA(1)'="[DATA]") ;-->out
  1. D SAVEOK
  1. K YS D ANSSET
  1. ;save results
  1. K YS S YS("AD")=YS84IEN D SCORSAVE^YTQAPI11(.YSDATA,.YS)
  1. ;send to nat db
  1. K YS S YS("AD")=YS84IEN D HL7^YTQHL7(.YSDATA,.YS)
  1. K ^TMP($J,"YSQU")
  1. Q
  1. ALLIN ;check cr Entries ok
  1. S YSCODE=$G(YS("CODE"),0)
  1. S YSTESTN=$O(^YTT(601.71,"B",YSCODE,0))
  1. I YSTESTN'>0 S YSDATA(1)="[ERROR]",YSDATA(2)="bad code" Q ;-->out
  1. D QUESTALL^YTQPXRM3(.YSDATAZ,.YS)
  1. I ^TMP($J,"YSQU",1)="[ERROR]" S YSDATA(1)="[ERROR]",YSDATA(2)="QUESTALL ERROR "_^TMP($J,"YSQU",2) Q ;-->out
  1. ;set answers
  1. S N=0 F S N=$O(YS(N)) Q:N'>0 S YSANS(+YS(N))=$P(YS(N),U,2)
  1. ;Skip logic fire -only first condition-no consistency only checks
  1. S N=0 F S N=$O(^TMP($J,"YSQU","YSCROSS",N)) Q:N'>0 D:$D(YSANS(N))
  1. . S YSQN=^TMP($J,"YSQU","YSCROSS",N)
  1. . Q:'$D(^YTT(601.83,"AD",YSTESTN,YSQN))
  1. . S N83=0
  1. . F S N83=$O(^YTT(601.83,"AD",YSTESTN,YSQN,N83)) Q:N83'>0 D
  1. .. S YSRULID=$P(^YTT(601.83,N83,0),U,4)
  1. .. S YSRG=^YTT(601.82,YSRULID,0)
  1. .. S YSQ1=$P(YSRG,U,2),YSIV=$P(YSRG,U,3),YSBOP1=$$BOOL($P(YSRG,U,5))
  1. .. S:YSBOP1="=<" YSBOP1="<",YSIV=YSIV+.1
  1. .. S:YSBOP1="=>" YSBOP1=">",YSIV=YSIV-.1
  1. .. S YSANSIV=$F(^TMP($J,"YSQU",N,"R",0),YSANS(N))-2
  1. .. S YSX="S YSRULE=0 I ("_YSANSIV_YSBOP1_YSIV_") S YSRULE=1"
  1. .. X YSX
  1. .. I $G(YSRULE)=1 S J=0 F S J=$O(^YTT(601.79,"AE",YSRULID,J)) Q:J'>0 S ^TMP($J,"YSQU","YSKIP",$P($G(^YTT(601.79,J,0),0),U,4))=""
  1. ; check all required answers present and legal
  1. S YSERR=""
  1. S N=0 F S N=$O(^TMP($J,"YSQU","YSCROSS",N)) Q:N'>0 D
  1. . S YSQN=^TMP($J,"YSQU","YSCROSS",N)
  1. . I $D(YSANS(N)) S:(^TMP($J,"YSQU",N,"R",0)'[YSANS(N)) YSERR="0^"_$P(YSERR,U,2)_N_"," ;answer not legal
  1. . ;I $P(^YTT(601.72,YSQN,2),U,6)="N" Q ;-->out not a required ques
  1. . I $D(^TMP($J,"YSQU","YSKIP",YSQN)) Q ;-->out skip rule
  1. . I '$D(YSANS(N)) S YSERR="0^"_$P(YSERR,U,2)_N_"," ; error set req answer not present
  1. I $L(YSERR)>1 S YSDATA(1)="[ERROR]" S YSDATA(2)=YSERR K ^TMP($J,"YSQU") Q ;-->out error state
  1. Q
  1. SAVEOK ; checks out so save admin
  1. S:'$D(YSADATE) YSADATE="NOW"
  1. S:'$D(YSSTAFF) YSSTAFF=DUZ
  1. S YSNEWA("FILEN")=601.84,YSNEWA(1)=".01^NEW^1",YSNEWA(2)="1^`"_DFN
  1. S YSNEWA(3)="2^"_YSCODE,YSNEWA(4)="3^"_YSADATE,YSNEWA(5)="4^NOW"
  1. S YSNEWA(6)="5^`"_YSSTAFF,YSNEWA(7)="6^`"_DUZ,YSNEWA(8)="7^N",YSNEWA(9)="8^Y"
  1. ;ASF 8/13 staff and orderer passing
  1. D EDAD^YTQAPI1(.YSADDER,.YSNEWA)
  1. S YS84IEN=$P(YSADDER(2),U,2)
  1. Q
  1. ANSSET ;save answers
  1. S N=0 F S N=$O(^TMP($J,"YSQU","YSCROSS",N)) Q:N'>0 D
  1. . Q:'$D(YSANS(N))
  1. . S YS("AD")=YS84IEN
  1. . S YS("QN")=^TMP($J,"YSQU","YSCROSS",N)
  1. . S YS("CHOICE")=^TMP($J,"YSQU","YSCA",YS("QN"),YSANS(N)) ;ASF 10/19
  1. . ;S YS(1)=YSANS(N)
  1. . D SETANS^YTQAPI2(.YSDATA,.YS)
  1. Q
  1. BOOL(YSOP) ;
  1. S YSOP=$S(YSOP="Equals":"=",YSOP="Is greater than":">",YSOP="Is less than":"<",YSOP="Equals or is less than":"=<",YSOP="Equals or is greater than":"=>",1:"")
  1. Q YSOP