- YTQPXRM4 ;ASF/ALB - CLINICAL REMINDERS CONT ; 10/29/07 3:06pm
- ;;5.01;MENTAL HEALTH;**85,240**;DEC 30,1994;Build 10
- ;
- Q
- CHECKCR(YSDATA,YS) ;check out cr dialog is ok
- ; input: CODE,DFN,^TMP($J,AARAY,sequential)=ITEM#^RESPONSE
- ;output [DATA] VS [ERROR]
- ;scoring in ^TMP($J,"YSCOR"
- N DA,DFN,N,YSV,YSCODE,YSQNUMB,YSADDER,YSNEWA,YSADDER,YSDATAZ,YSANS,YSX,YSBOP1
- N YSERR,YSLEGA,YSRR,YSCHOT,YSCHOICE,G,YSLN,YSIC,YSQN,YSF,YSCODE,J,N83,YSANSIV,YSIV,YSQ1,YSRG,YSRULE,YSRULID,DIK,YS84IEN,J1,YSTESTN
- S DFN=$G(YS("DFN"),-1) I '$D(^DPT(DFN)) S YSDATA(1)="ERROR",YSDATA(2)="bad DFN" Q ;-->out
- S YSDATA(1)="[DATA]"
- D ALLIN
- Q:(YSDATA(1)'="[DATA]") ;-->out
- D SAVEOK
- N YSEVDFN,YSEVTST,YSEVCPLT
- S YSEVDFN=+$P($G(^YTT(601.84,+YS84IEN,0)),U,2)
- S YSEVTST=+$P($G(^YTT(601.84,+YS84IEN,0)),U,3)
- S YSEVTST=$P($G(^YTT(601.71,YSEVTST,0)),U)
- S YSEVCPLT=($P($G(^YTT(601.84,+YS84IEN,0)),U,9)="Y")
- L +^YTT(601.84,YS84IEN):30
- K YS D ANSSET
- D GETSCORE^YTQAPI8(.YSV,.YS)
- ; delete admin as it is not fully ok'd
- 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
- . K DIK S DA=J1,DIK="^YTT(601.85," D ^DIK
- K DIK S DA=YS84IEN,DIK="^YTT(601.84," D ^DIK ;moved 10/29/07 asf
- L -^YTT(601.84,YS84IEN):30
- ; publish delete event for admin if it was completed
- I YSEVCPLT D DELETE^YTQEVNT(YS84IEN,YSEVDFN,YSEVTST,"crdel")
- K ^TMP($J,"YSQU")
- Q
- SAVECR(YSDATA,YS) ;save cr entered instruments
- ; input: CODE,DFN,^TMP($J,AARAY,sequential)=ITEM#^RESPONSE
- ;output [DATA] VS [ERROR]
- N DA,DFN,N,YSCODE,YSQNUMB,YSADDER,YSNEWA,YSADDER,YS84IEN,YSDATAZ,YSANS,YSX,YSBOP1,YSSTAFF,YSADATE
- N YSERR,YSLEGA,YSRR,YSCHOT,YSCHOICE,G,YSLN,YSIC,YSQN,YSF,YSCODE,J,N83,YSANSIV,YSIV,YSQ1,YSRG,YSRULE,YSRULID,J1,YSTESTN
- S DFN=$G(YS("DFN"),-1) I '$D(^DPT(DFN)) S YSDATA(1)="ERROR",YSDATA(2)="bad DFN" Q ;-->out
- S YSADATE=$G(YS("ADATE"),"NOW")
- S YSSTAFF=$G(YS("STAFF"),DUZ)
- S YSDATA(1)="[DATA]"
- D ALLIN
- Q:(YSDATA(1)'="[DATA]") ;-->out
- D SAVEOK
- K YS D ANSSET
- ;save results
- K YS S YS("AD")=YS84IEN D SCORSAVE^YTQAPI11(.YSDATA,.YS)
- ;send to nat db
- K YS S YS("AD")=YS84IEN D HL7^YTQHL7(.YSDATA,.YS)
- K ^TMP($J,"YSQU")
- Q
- ALLIN ;check cr Entries ok
- S YSCODE=$G(YS("CODE"),0)
- S YSTESTN=$O(^YTT(601.71,"B",YSCODE,0))
- I YSTESTN'>0 S YSDATA(1)="[ERROR]",YSDATA(2)="bad code" Q ;-->out
- D QUESTALL^YTQPXRM3(.YSDATAZ,.YS)
- I ^TMP($J,"YSQU",1)="[ERROR]" S YSDATA(1)="[ERROR]",YSDATA(2)="QUESTALL ERROR "_^TMP($J,"YSQU",2) Q ;-->out
- ;set answers
- S N=0 F S N=$O(YS(N)) Q:N'>0 S YSANS(+YS(N))=$P(YS(N),U,2)
- ;Skip logic fire -only first condition-no consistency only checks
- S N=0 F S N=$O(^TMP($J,"YSQU","YSCROSS",N)) Q:N'>0 D:$D(YSANS(N))
- . S YSQN=^TMP($J,"YSQU","YSCROSS",N)
- . Q:'$D(^YTT(601.83,"AD",YSTESTN,YSQN))
- . S N83=0
- . F S N83=$O(^YTT(601.83,"AD",YSTESTN,YSQN,N83)) Q:N83'>0 D
- .. S YSRULID=$P(^YTT(601.83,N83,0),U,4)
- .. S YSRG=^YTT(601.82,YSRULID,0)
- .. S YSQ1=$P(YSRG,U,2),YSIV=$P(YSRG,U,3),YSBOP1=$$BOOL($P(YSRG,U,5))
- .. S:YSBOP1="=<" YSBOP1="<",YSIV=YSIV+.1
- .. S:YSBOP1="=>" YSBOP1=">",YSIV=YSIV-.1
- .. S YSANSIV=$F(^TMP($J,"YSQU",N,"R",0),YSANS(N))-2
- .. S YSX="S YSRULE=0 I ("_YSANSIV_YSBOP1_YSIV_") S YSRULE=1"
- .. X YSX
- .. 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))=""
- ; check all required answers present and legal
- S YSERR=""
- S N=0 F S N=$O(^TMP($J,"YSQU","YSCROSS",N)) Q:N'>0 D
- . S YSQN=^TMP($J,"YSQU","YSCROSS",N)
- . I $D(YSANS(N)) S:(^TMP($J,"YSQU",N,"R",0)'[YSANS(N)) YSERR="0^"_$P(YSERR,U,2)_N_"," ;answer not legal
- . ;I $P(^YTT(601.72,YSQN,2),U,6)="N" Q ;-->out not a required ques
- . I $D(^TMP($J,"YSQU","YSKIP",YSQN)) Q ;-->out skip rule
- . I '$D(YSANS(N)) S YSERR="0^"_$P(YSERR,U,2)_N_"," ; error set req answer not present
- I $L(YSERR)>1 S YSDATA(1)="[ERROR]" S YSDATA(2)=YSERR K ^TMP($J,"YSQU") Q ;-->out error state
- Q
- SAVEOK ; checks out so save admin
- S:'$D(YSADATE) YSADATE="NOW"
- S:'$D(YSSTAFF) YSSTAFF=DUZ
- S YSNEWA("FILEN")=601.84,YSNEWA(1)=".01^NEW^1",YSNEWA(2)="1^`"_DFN
- S YSNEWA(3)="2^"_YSCODE,YSNEWA(4)="3^"_YSADATE,YSNEWA(5)="4^NOW"
- S YSNEWA(6)="5^`"_YSSTAFF,YSNEWA(7)="6^`"_DUZ,YSNEWA(8)="7^N",YSNEWA(9)="8^Y"
- ;ASF 8/13 staff and orderer passing
- D EDAD^YTQAPI1(.YSADDER,.YSNEWA)
- S YS84IEN=$P(YSADDER(2),U,2)
- Q
- ANSSET ;save answers
- S N=0 F S N=$O(^TMP($J,"YSQU","YSCROSS",N)) Q:N'>0 D
- . Q:'$D(YSANS(N))
- . S YS("AD")=YS84IEN
- . S YS("QN")=^TMP($J,"YSQU","YSCROSS",N)
- . S YS("CHOICE")=^TMP($J,"YSQU","YSCA",YS("QN"),YSANS(N)) ;ASF 10/19
- . ;S YS(1)=YSANS(N)
- . D SETANS^YTQAPI2(.YSDATA,.YS)
- Q
- BOOL(YSOP) ;
- 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:"")
- Q YSOP
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQPXRM4 4863 printed Feb 18, 2025@23:44:53 Page 2
- YTQPXRM4 ;ASF/ALB - CLINICAL REMINDERS CONT ; 10/29/07 3:06pm
- +1 ;;5.01;MENTAL HEALTH;**85,240**;DEC 30,1994;Build 10
- +2 ;
- +3 QUIT
- CHECKCR(YSDATA,YS) ;check out cr dialog is ok
- +1 ; input: CODE,DFN,^TMP($J,AARAY,sequential)=ITEM#^RESPONSE
- +2 ;output [DATA] VS [ERROR]
- +3 ;scoring in ^TMP($J,"YSCOR"
- +4 NEW DA,DFN,N,YSV,YSCODE,YSQNUMB,YSADDER,YSNEWA,YSADDER,YSDATAZ,YSANS,YSX,YSBOP1
- +5 NEW YSERR,YSLEGA,YSRR,YSCHOT,YSCHOICE,G,YSLN,YSIC,YSQN,YSF,YSCODE,J,N83,YSANSIV,YSIV,YSQ1,YSRG,YSRULE,YSRULID,DIK,YS84IEN,J1,YSTESTN
- +6 ;-->out
- SET DFN=$GET(YS("DFN"),-1)
- IF '$DATA(^DPT(DFN))
- SET YSDATA(1)="ERROR"
- SET YSDATA(2)="bad DFN"
- QUIT
- +7 SET YSDATA(1)="[DATA]"
- +8 DO ALLIN
- +9 ;-->out
- if (YSDATA(1)'="[DATA]")
- QUIT
- +10 DO SAVEOK
- +11 NEW YSEVDFN,YSEVTST,YSEVCPLT
- +12 SET YSEVDFN=+$PIECE($GET(^YTT(601.84,+YS84IEN,0)),U,2)
- +13 SET YSEVTST=+$PIECE($GET(^YTT(601.84,+YS84IEN,0)),U,3)
- +14 SET YSEVTST=$PIECE($GET(^YTT(601.71,YSEVTST,0)),U)
- +15 SET YSEVCPLT=($PIECE($GET(^YTT(601.84,+YS84IEN,0)),U,9)="Y")
- +16 LOCK +^YTT(601.84,YS84IEN):30
- +17 KILL YS
- DO ANSSET
- +18 DO GETSCORE^YTQAPI8(.YSV,.YS)
- +19 ; delete admin as it is not fully ok'd
- +20 SET J=0
- FOR
- SET J=$ORDER(^YTT(601.85,"AC",YS84IEN,J))
- if J'>0
- QUIT
- SET J1=0
- FOR
- SET J1=$ORDER(^YTT(601.85,"AC",YS84IEN,J,J1))
- if J1'>0
- QUIT
- Begin DoDot:1
- +21 KILL DIK
- SET DA=J1
- SET DIK="^YTT(601.85,"
- DO ^DIK
- End DoDot:1
- +22 ;moved 10/29/07 asf
- KILL DIK
- SET DA=YS84IEN
- SET DIK="^YTT(601.84,"
- DO ^DIK
- +23 LOCK -^YTT(601.84,YS84IEN):30
- +24 ; publish delete event for admin if it was completed
- +25 IF YSEVCPLT
- DO DELETE^YTQEVNT(YS84IEN,YSEVDFN,YSEVTST,"crdel")
- +26 KILL ^TMP($JOB,"YSQU")
- +27 QUIT
- SAVECR(YSDATA,YS) ;save cr entered instruments
- +1 ; input: CODE,DFN,^TMP($J,AARAY,sequential)=ITEM#^RESPONSE
- +2 ;output [DATA] VS [ERROR]
- +3 NEW DA,DFN,N,YSCODE,YSQNUMB,YSADDER,YSNEWA,YSADDER,YS84IEN,YSDATAZ,YSANS,YSX,YSBOP1,YSSTAFF,YSADATE
- +4 NEW YSERR,YSLEGA,YSRR,YSCHOT,YSCHOICE,G,YSLN,YSIC,YSQN,YSF,YSCODE,J,N83,YSANSIV,YSIV,YSQ1,YSRG,YSRULE,YSRULID,J1,YSTESTN
- +5 ;-->out
- SET DFN=$GET(YS("DFN"),-1)
- IF '$DATA(^DPT(DFN))
- SET YSDATA(1)="ERROR"
- SET YSDATA(2)="bad DFN"
- QUIT
- +6 SET YSADATE=$GET(YS("ADATE"),"NOW")
- +7 SET YSSTAFF=$GET(YS("STAFF"),DUZ)
- +8 SET YSDATA(1)="[DATA]"
- +9 DO ALLIN
- +10 ;-->out
- if (YSDATA(1)'="[DATA]")
- QUIT
- +11 DO SAVEOK
- +12 KILL YS
- DO ANSSET
- +13 ;save results
- +14 KILL YS
- SET YS("AD")=YS84IEN
- DO SCORSAVE^YTQAPI11(.YSDATA,.YS)
- +15 ;send to nat db
- +16 KILL YS
- SET YS("AD")=YS84IEN
- DO HL7^YTQHL7(.YSDATA,.YS)
- +17 KILL ^TMP($JOB,"YSQU")
- +18 QUIT
- ALLIN ;check cr Entries ok
- +1 SET YSCODE=$GET(YS("CODE"),0)
- +2 SET YSTESTN=$ORDER(^YTT(601.71,"B",YSCODE,0))
- +3 ;-->out
- IF YSTESTN'>0
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="bad code"
- QUIT
- +4 DO QUESTALL^YTQPXRM3(.YSDATAZ,.YS)
- +5 ;-->out
- IF ^TMP($JOB,"YSQU",1)="[ERROR]"
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="QUESTALL ERROR "_^TMP($JOB,"YSQU",2)
- QUIT
- +6 ;set answers
- +7 SET N=0
- FOR
- SET N=$ORDER(YS(N))
- if N'>0
- QUIT
- SET YSANS(+YS(N))=$PIECE(YS(N),U,2)
- +8 ;Skip logic fire -only first condition-no consistency only checks
- +9 SET N=0
- FOR
- SET N=$ORDER(^TMP($JOB,"YSQU","YSCROSS",N))
- if N'>0
- QUIT
- if $DATA(YSANS(N))
- Begin DoDot:1
- +10 SET YSQN=^TMP($JOB,"YSQU","YSCROSS",N)
- +11 if '$DATA(^YTT(601.83,"AD",YSTESTN,YSQN))
- QUIT
- +12 SET N83=0
- +13 FOR
- SET N83=$ORDER(^YTT(601.83,"AD",YSTESTN,YSQN,N83))
- if N83'>0
- QUIT
- Begin DoDot:2
- +14 SET YSRULID=$PIECE(^YTT(601.83,N83,0),U,4)
- +15 SET YSRG=^YTT(601.82,YSRULID,0)
- +16 SET YSQ1=$PIECE(YSRG,U,2)
- SET YSIV=$PIECE(YSRG,U,3)
- SET YSBOP1=$$BOOL($PIECE(YSRG,U,5))
- +17 if YSBOP1="=<"
- SET YSBOP1="<"
- SET YSIV=YSIV+.1
- +18 if YSBOP1="=>"
- SET YSBOP1=">"
- SET YSIV=YSIV-.1
- +19 SET YSANSIV=$FIND(^TMP($JOB,"YSQU",N,"R",0),YSANS(N))-2
- +20 SET YSX="S YSRULE=0 I ("_YSANSIV_YSBOP1_YSIV_") S YSRULE=1"
- +21 XECUTE YSX
- +22 IF $GET(YSRULE)=1
- SET J=0
- FOR
- SET J=$ORDER(^YTT(601.79,"AE",YSRULID,J))
- if J'>0
- QUIT
- SET ^TMP($JOB,"YSQU","YSKIP",$PIECE($GET(^YTT(601.79,J,0),0),U,4))=""
- End DoDot:2
- End DoDot:1
- +23 ; check all required answers present and legal
- +24 SET YSERR=""
- +25 SET N=0
- FOR
- SET N=$ORDER(^TMP($JOB,"YSQU","YSCROSS",N))
- if N'>0
- QUIT
- Begin DoDot:1
- +26 SET YSQN=^TMP($JOB,"YSQU","YSCROSS",N)
- +27 ;answer not legal
- IF $DATA(YSANS(N))
- if (^TMP($JOB,"YSQU",N,"R",0)'[YSANS(N))
- SET YSERR="0^"_$PIECE(YSERR,U,2)_N_","
- +28 ;I $P(^YTT(601.72,YSQN,2),U,6)="N" Q ;-->out not a required ques
- +29 ;-->out skip rule
- IF $DATA(^TMP($JOB,"YSQU","YSKIP",YSQN))
- QUIT
- +30 ; error set req answer not present
- IF '$DATA(YSANS(N))
- SET YSERR="0^"_$PIECE(YSERR,U,2)_N_","
- End DoDot:1
- +31 ;-->out error state
- IF $LENGTH(YSERR)>1
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)=YSERR
- KILL ^TMP($JOB,"YSQU")
- QUIT
- +32 QUIT
- SAVEOK ; checks out so save admin
- +1 if '$DATA(YSADATE)
- SET YSADATE="NOW"
- +2 if '$DATA(YSSTAFF)
- SET YSSTAFF=DUZ
- +3 SET YSNEWA("FILEN")=601.84
- SET YSNEWA(1)=".01^NEW^1"
- SET YSNEWA(2)="1^`"_DFN
- +4 SET YSNEWA(3)="2^"_YSCODE
- SET YSNEWA(4)="3^"_YSADATE
- SET YSNEWA(5)="4^NOW"
- +5 SET YSNEWA(6)="5^`"_YSSTAFF
- SET YSNEWA(7)="6^`"_DUZ
- SET YSNEWA(8)="7^N"
- SET YSNEWA(9)="8^Y"
- +6 ;ASF 8/13 staff and orderer passing
- +7 DO EDAD^YTQAPI1(.YSADDER,.YSNEWA)
- +8 SET YS84IEN=$PIECE(YSADDER(2),U,2)
- +9 QUIT
- ANSSET ;save answers
- +1 SET N=0
- FOR
- SET N=$ORDER(^TMP($JOB,"YSQU","YSCROSS",N))
- if N'>0
- QUIT
- Begin DoDot:1
- +2 if '$DATA(YSANS(N))
- QUIT
- +3 SET YS("AD")=YS84IEN
- +4 SET YS("QN")=^TMP($JOB,"YSQU","YSCROSS",N)
- +5 ;ASF 10/19
- SET YS("CHOICE")=^TMP($JOB,"YSQU","YSCA",YS("QN"),YSANS(N))
- +6 ;S YS(1)=YSANS(N)
- +7 DO SETANS^YTQAPI2(.YSDATA,.YS)
- End DoDot:1
- +8 QUIT
- BOOL(YSOP) ;
- +1 SET YSOP=$SELECT(YSOP="Equals":"=",YSOP="Is greater than":">",YSOP="Is less than":"<",YSOP="Equals or is less than":"=<",YSOP="Equals or is greater than":"=>",1:"")
- +2 QUIT YSOP