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