YTQAPI14 ;ASF/ALB - MHA PROCEDURES ; 1/20/11 2:15pm
;;5.01;MENTAL HEALTH;**85,97,96,103,119,121**;Dec 30, 1994;Build 61
Q
;Reference to ^XUSEC( supported by DBIA #10076
;Reference to ^DPT( supported by DBIA #10035
;Reference to ^PXRMINDX(601.84, supported by DBIA #4290
;Reference to FILE 870 supported by DBIA #5603
RESEND ;resend all no transmits and errors
N YSDATE,YSAD,YSTS,YSFILT,YSBEG,YSEND,YSSNDFLG
W @IOF,!,"MHA3 HL7 Resends",!!,"CAUTION:: use only if instructed by National Support Staff",!
K DIR S DIR(0)="Y",DIR("B")="No",DIR("A")="Continue" D ^DIR Q:$D(DIRUT)
Q:Y=0
K DIR S DIR(0)="D^:DT:EX",DIR("A")="Begin Date" D ^DIR Q:$D(DIRUT)
S YSBEG=Y
K DIR S DIR(0)="D^"_Y_":DT:EX",DIR("A")="End Date" D ^DIR Q:$D(DIRUT)
S YSEND=Y
K DIR S DIR(0)="S^E:Errors only;T:Awaiting Transmission only;B:Both Errors;A:All administrations",DIR("A")="Filter resend" D ^DIR Q:$D(DIRUT)
S YSFILT=Y
S YSCODE=0,N1=0 F S YSCODE=$O(^YTT(601.84,"AC",YSCODE)) Q:YSCODE'>0 D
. S YSSNDFLG=$P($G(^YTT(601.71,YSCODE,8)),U,4)
. Q:YSSNDFLG'="Y"
. S YSDATE=YSBEG,YSEND=YSEND+.9
. F S YSDATE=$O(^YTT(601.84,"AC",YSCODE,YSDATE)) Q:YSDATE'>0!(YSDATE>YSEND) D
.. S YSAD=0 F S YSAD=$O(^YTT(601.84,"AC",YSCODE,YSDATE,YSAD)) Q:YSAD'>0 D Q
... S YSTS=$P($G(^YTT(601.84,YSAD,2)),U)
... Q:YSTS="" ;-->out never send --incomplete
... I YSFILT="E" Q:YSTS'="E"
... I YSFILT="T" Q:YSTS'="T"
... I YSFILT="B" Q:(YSTS'="E")&(YSTS'="T")
... D NULLNOW
... K YS,YSDATA S YS("AD")=YSAD D HL7^YTQHL7(.YSDATA,.YS)
... S N1=N1+1 ;W !,N1," ",YSAD," date=",YSDATE," stat= ",YSTS
W !,N1," messages resent"
Q
NULLNOW ;set transmission status to "" and NOW
N DIE,DR,DA
S DA=YSAD,DIE="^YTT(601.84,",DR="11////@;12///NOW"
NN1 ;re-entry if lock fails
L +^YTT(601.84,DA):DILOCKTM I '$T H 10 G NN1
D ^DIE
L -^YTT(601.84,DA)
Q
CKHL7 ;check hl7 status
N DIC,DA
W @IOF,!?15,"*** HL7 Check ***",!
S X="YS MHAT",DIC=870 D ^DIC
I +Y'>0 W !,"YS MHAT ERROR" Q ;-->out
S DA=+Y D EN^DIQ
S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Continue" D ^DIR Q:$D(DIRUT)
Q:Y=0
D SELADM^YTQAPI14(.YSAD)
Q:YSAD'>0 ;-->out
S DIC="^YTT(601.84,",DA=YSAD D EN^DIQ
Q
SEND1 ;send single HL7 by pt & test
N DIC,YSAD
D SELADM^YTQAPI14(.YSAD)
Q:YSAD'>0
K YS,YSDATA
D NULLNOW
S YS("AD")=YSAD D HL7^YTQHL7(.YSDATA,.YS)
W !,"HL7 message created..."
Q
SELADM(YSADIEN) ;select admin by pt and test
N N,YSGIVEN,DIC,DFN,YSCODEN,YSDFN,YTTLKUP
S YSADIEN=0,YTTLKUP=1 ; suppress filter
D ^YSLRP Q:YSDFN'>0
S DIC="^YTT(601.71,",DIC(0)="AEQ" D ^DIC Q:Y'>0
S YSCODEN=+Y
S YSGIVEN=0
F S YSGIVEN=$O(^PXRMINDX(601.84,"PI",YSDFN,YSCODEN,YSGIVEN)) Q:YSGIVEN'>0 D
. S N=0 F S N=$O(^PXRMINDX(601.84,"PI",DFN,YSCODEN,YSGIVEN,N)) Q:N'>0 D
.. W !,N
.. S Y=YSGIVEN D DD^%DT W ?15,Y
S DIC="^YTT(601.84,",DIC(0)="AEQ" D ^DIC
S YSADIEN=+Y
Q
NOPNOTE ;entry point for YTQ PNOTE FLAG option
N DIE,DIC,X,Y,DA,DR,YTTLKUP
S YTTLKUP=1 ; suppress filter
S DIC="^YTT(601.71,",DIC(0)="AEMQ" D ^DIC Q:Y'>0
S DIE="^YTT(601.71,",DA=+Y,DR="28;29;30" D ^DIE
I $G(DA) D NEWDATE^YTXCHGU(DA) ; so GUI will pick up the change
Q
EXEMPT ;exempt by adim and report
N DIE,DIC,X,Y,DA,DR,YTTLKUP
W @IOF,!,"*** Exempt Test ***",!!
W "Caution-- changing the exempt level of a published test may break copyright",!,"agreements. Changes to national tests are at the risk of the changing facility.",!!
S YTTLKUP=1 ; suppress filter
S DIC="^YTT(601.71,",DIC(0)="AEMQ" D ^DIC Q:Y'>0
S DIE="^YTT(601.71,",DA=+Y,DR="8;9;27;18///NOW" D ^DIE
Q
SIGNOK(YSDATA,YS) ;entry point for YTQ ASI SIGNOK rpc
;Input: IENS as iens for 604
;Output: 1^OK TO SIGN
; 0^MISSING REQUIRED FIELDS
; 2^A G12 RECORD
N N1,YSASCLS,X,YSASFLD,YSF,YSN,YSFLAG,YSIEN,YSTYPE
S YSFLAG=1
S YSIEN=$G(YS("IENS"),-1)
I '$D(^YSTX(604,YSIEN,0)) S YSDATA(1)="[ERROR]",YSDATA(2)="BAD IEN" Q
S YSDATA(1)="[DATA]",YSDATA(2)="1^OK TO SIGN"
S YSN=2
S YSASCLS=$$GET1^DIQ(604,YSIEN_",",.04,"I")
S YSASCLS=YSASCLS+3
S N1=0 F S N1=$O(^YSTX(604.66,N1)) Q:N1'>0 D:($P(^YSTX(604.66,N1,0),U,8)&($P(^YSTX(604.66,N1,0),U,YSASCLS)))
. S YSASFLD=$P(^YSTX(604.66,N1,0),U,3)
. D TYPE
. S YSF=$S(YSASFLD>10.02&(YSASFLD<10.44):"I",YSTYPE=1:"",1:"I")
. S X=$$GET1^DIQ(604,YSIEN,YSASFLD,YSF)
. S:X="" YSFLAG=0,YSN=YSN+1,YSDATA(YSN)=^YSTX(604.66,N1,0)
S X=$$GET1^DIQ(604,YSIEN,YSASFLD,.11)
S:X="X"!(X="N") YSFLAG=2
S:YSFLAG=0 YSDATA(2)="0^MISSING REQUIRED FIELDS"
S:YSFLAG=2 YSDATA(2)="2^A G12 RECORD"
Q
TYPE ;check field type
;O = NOT A POINTER 1 = POINTER
N YSFLD
S YSTYPE=0
D FIELD^DID(604,YSASFLD,"","TYPE","YSFLD")
S:YSFLD("TYPE")="POINTER" YSTYPE=1
Q
SCOREIT(YSDATA,YS) ; from YTQAPI8
N N,N2,N4,R,S,YSAA,I,II,DFN,YSCODE,YSADATE,YSSCALE,YSBED,YSEND,YSED,YSET,YSR,YSSX,YSTN
K YSDATA,YSSONE
D PARSE^YTAPI(.YS)
SCOR1 S (YSTEST,YSET)=$O(^YTT(601,"B",YSCODE,0))
S YSED=YSADATE
S YSDFN=DFN
S YSSX=$P(^DPT(DFN,0),U,2)
S YSTN=YSCODE
IF '$D(^YTD(601.2,YSDFN,1,YSET,1,YSED)) S YSDATA(1)="[ERROR SCORE1+5]",YSDATA(2)="no administration found" Q
D PRIV ;check it
S YSR(0)=$G(^YTT(601.6,YSET,0))
I $P(YSR(0),U,2)="Y" S X=^YTT(601.6,YSET,1) X X
Q:$G(YSDATA(1))?1"[ERROR".E
D SCORSET^YTAPI2
D:YSPRIV SF^YTAPI2
S N1=0
F S N1=$O(YSSONE(N1)) Q:N1'>0 S N=N+1,YSDATA(N)=YSSONE(N1)
D CLEAN^YSMTI5 Q
PRIV ;check privileges
N YS71,YSKEY
S YSPRIV=0
S YS71=$O(^YTT(601.71,"B",YSTN,0))
Q:YS71'>0 ;-->out error
S YSKEY=$$GET1^DIQ(601.71,YS71_",",9)
I YSKEY="" S YSPRIV=1 Q ;-->out exempt
I $D(^XUSEC(YSKEY,DUZ)) S YSPRIV=1 Q ;-->out has key
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQAPI14 5630 printed Apr 09, 2024@21:21:03 Page 2
YTQAPI14 ;ASF/ALB - MHA PROCEDURES ; 1/20/11 2:15pm
+1 ;;5.01;MENTAL HEALTH;**85,97,96,103,119,121**;Dec 30, 1994;Build 61
+2 QUIT
+3 ;Reference to ^XUSEC( supported by DBIA #10076
+4 ;Reference to ^DPT( supported by DBIA #10035
+5 ;Reference to ^PXRMINDX(601.84, supported by DBIA #4290
+6 ;Reference to FILE 870 supported by DBIA #5603
RESEND ;resend all no transmits and errors
+1 NEW YSDATE,YSAD,YSTS,YSFILT,YSBEG,YSEND,YSSNDFLG
+2 WRITE @IOF,!,"MHA3 HL7 Resends",!!,"CAUTION:: use only if instructed by National Support Staff",!
+3 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="No"
SET DIR("A")="Continue"
DO ^DIR
if $DATA(DIRUT)
QUIT
+4 if Y=0
QUIT
+5 KILL DIR
SET DIR(0)="D^:DT:EX"
SET DIR("A")="Begin Date"
DO ^DIR
if $DATA(DIRUT)
QUIT
+6 SET YSBEG=Y
+7 KILL DIR
SET DIR(0)="D^"_Y_":DT:EX"
SET DIR("A")="End Date"
DO ^DIR
if $DATA(DIRUT)
QUIT
+8 SET YSEND=Y
+9 KILL DIR
SET DIR(0)="S^E:Errors only;T:Awaiting Transmission only;B:Both Errors;A:All administrations"
SET DIR("A")="Filter resend"
DO ^DIR
if $DATA(DIRUT)
QUIT
+10 SET YSFILT=Y
+11 SET YSCODE=0
SET N1=0
FOR
SET YSCODE=$ORDER(^YTT(601.84,"AC",YSCODE))
if YSCODE'>0
QUIT
Begin DoDot:1
+12 SET YSSNDFLG=$PIECE($GET(^YTT(601.71,YSCODE,8)),U,4)
+13 if YSSNDFLG'="Y"
QUIT
+14 SET YSDATE=YSBEG
SET YSEND=YSEND+.9
+15 FOR
SET YSDATE=$ORDER(^YTT(601.84,"AC",YSCODE,YSDATE))
if YSDATE'>0!(YSDATE>YSEND)
QUIT
Begin DoDot:2
+16 SET YSAD=0
FOR
SET YSAD=$ORDER(^YTT(601.84,"AC",YSCODE,YSDATE,YSAD))
if YSAD'>0
QUIT
Begin DoDot:3
+17 SET YSTS=$PIECE($GET(^YTT(601.84,YSAD,2)),U)
+18 ;-->out never send --incomplete
if YSTS=""
QUIT
+19 IF YSFILT="E"
if YSTS'="E"
QUIT
+20 IF YSFILT="T"
if YSTS'="T"
QUIT
+21 IF YSFILT="B"
if (YSTS'="E")&(YSTS'="T")
QUIT
+22 DO NULLNOW
+23 KILL YS,YSDATA
SET YS("AD")=YSAD
DO HL7^YTQHL7(.YSDATA,.YS)
+24 ;W !,N1," ",YSAD," date=",YSDATE," stat= ",YSTS
SET N1=N1+1
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+25 WRITE !,N1," messages resent"
+26 QUIT
NULLNOW ;set transmission status to "" and NOW
+1 NEW DIE,DR,DA
+2 SET DA=YSAD
SET DIE="^YTT(601.84,"
SET DR="11////@;12///NOW"
NN1 ;re-entry if lock fails
+1 LOCK +^YTT(601.84,DA):DILOCKTM
IF '$TEST
HANG 10
GOTO NN1
+2 DO ^DIE
+3 LOCK -^YTT(601.84,DA)
+4 QUIT
CKHL7 ;check hl7 status
+1 NEW DIC,DA
+2 WRITE @IOF,!?15,"*** HL7 Check ***",!
+3 SET X="YS MHAT"
SET DIC=870
DO ^DIC
+4 ;-->out
IF +Y'>0
WRITE !,"YS MHAT ERROR"
QUIT
+5 SET DA=+Y
DO EN^DIQ
+6 SET DIR(0)="Y"
SET DIR("B")="Yes"
SET DIR("A")="Continue"
DO ^DIR
if $DATA(DIRUT)
QUIT
+7 if Y=0
QUIT
+8 DO SELADM^YTQAPI14(.YSAD)
+9 ;-->out
if YSAD'>0
QUIT
+10 SET DIC="^YTT(601.84,"
SET DA=YSAD
DO EN^DIQ
+11 QUIT
SEND1 ;send single HL7 by pt & test
+1 NEW DIC,YSAD
+2 DO SELADM^YTQAPI14(.YSAD)
+3 if YSAD'>0
QUIT
+4 KILL YS,YSDATA
+5 DO NULLNOW
+6 SET YS("AD")=YSAD
DO HL7^YTQHL7(.YSDATA,.YS)
+7 WRITE !,"HL7 message created..."
+8 QUIT
SELADM(YSADIEN) ;select admin by pt and test
+1 NEW N,YSGIVEN,DIC,DFN,YSCODEN,YSDFN,YTTLKUP
+2 ; suppress filter
SET YSADIEN=0
SET YTTLKUP=1
+3 DO ^YSLRP
if YSDFN'>0
QUIT
+4 SET DIC="^YTT(601.71,"
SET DIC(0)="AEQ"
DO ^DIC
if Y'>0
QUIT
+5 SET YSCODEN=+Y
+6 SET YSGIVEN=0
+7 FOR
SET YSGIVEN=$ORDER(^PXRMINDX(601.84,"PI",YSDFN,YSCODEN,YSGIVEN))
if YSGIVEN'>0
QUIT
Begin DoDot:1
+8 SET N=0
FOR
SET N=$ORDER(^PXRMINDX(601.84,"PI",DFN,YSCODEN,YSGIVEN,N))
if N'>0
QUIT
Begin DoDot:2
+9 WRITE !,N
+10 SET Y=YSGIVEN
DO DD^%DT
WRITE ?15,Y
End DoDot:2
End DoDot:1
+11 SET DIC="^YTT(601.84,"
SET DIC(0)="AEQ"
DO ^DIC
+12 SET YSADIEN=+Y
+13 QUIT
NOPNOTE ;entry point for YTQ PNOTE FLAG option
+1 NEW DIE,DIC,X,Y,DA,DR,YTTLKUP
+2 ; suppress filter
SET YTTLKUP=1
+3 SET DIC="^YTT(601.71,"
SET DIC(0)="AEMQ"
DO ^DIC
if Y'>0
QUIT
+4 SET DIE="^YTT(601.71,"
SET DA=+Y
SET DR="28;29;30"
DO ^DIE
+5 ; so GUI will pick up the change
IF $GET(DA)
DO NEWDATE^YTXCHGU(DA)
+6 QUIT
EXEMPT ;exempt by adim and report
+1 NEW DIE,DIC,X,Y,DA,DR,YTTLKUP
+2 WRITE @IOF,!,"*** Exempt Test ***",!!
+3 WRITE "Caution-- changing the exempt level of a published test may break copyright",!,"agreements. Changes to national tests are at the risk of the changing facility.",!!
+4 ; suppress filter
SET YTTLKUP=1
+5 SET DIC="^YTT(601.71,"
SET DIC(0)="AEMQ"
DO ^DIC
if Y'>0
QUIT
+6 SET DIE="^YTT(601.71,"
SET DA=+Y
SET DR="8;9;27;18///NOW"
DO ^DIE
+7 QUIT
SIGNOK(YSDATA,YS) ;entry point for YTQ ASI SIGNOK rpc
+1 ;Input: IENS as iens for 604
+2 ;Output: 1^OK TO SIGN
+3 ; 0^MISSING REQUIRED FIELDS
+4 ; 2^A G12 RECORD
+5 NEW N1,YSASCLS,X,YSASFLD,YSF,YSN,YSFLAG,YSIEN,YSTYPE
+6 SET YSFLAG=1
+7 SET YSIEN=$GET(YS("IENS"),-1)
+8 IF '$DATA(^YSTX(604,YSIEN,0))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="BAD IEN"
QUIT
+9 SET YSDATA(1)="[DATA]"
SET YSDATA(2)="1^OK TO SIGN"
+10 SET YSN=2
+11 SET YSASCLS=$$GET1^DIQ(604,YSIEN_",",.04,"I")
+12 SET YSASCLS=YSASCLS+3
+13 SET N1=0
FOR
SET N1=$ORDER(^YSTX(604.66,N1))
if N1'>0
QUIT
if ($PIECE(^YSTX(604.66,N1,0),U,8)&($PIECE(^YSTX(604.66,N1,0),U,YSASCLS)))
Begin DoDot:1
+14 SET YSASFLD=$PIECE(^YSTX(604.66,N1,0),U,3)
+15 DO TYPE
+16 SET YSF=$SELECT(YSASFLD>10.02&(YSASFLD<10.44):"I",YSTYPE=1:"",1:"I")
+17 SET X=$$GET1^DIQ(604,YSIEN,YSASFLD,YSF)
+18 if X=""
SET YSFLAG=0
SET YSN=YSN+1
SET YSDATA(YSN)=^YSTX(604.66,N1,0)
End DoDot:1
+19 SET X=$$GET1^DIQ(604,YSIEN,YSASFLD,.11)
+20 if X="X"!(X="N")
SET YSFLAG=2
+21 if YSFLAG=0
SET YSDATA(2)="0^MISSING REQUIRED FIELDS"
+22 if YSFLAG=2
SET YSDATA(2)="2^A G12 RECORD"
+23 QUIT
TYPE ;check field type
+1 ;O = NOT A POINTER 1 = POINTER
+2 NEW YSFLD
+3 SET YSTYPE=0
+4 DO FIELD^DID(604,YSASFLD,"","TYPE","YSFLD")
+5 if YSFLD("TYPE")="POINTER"
SET YSTYPE=1
+6 QUIT
SCOREIT(YSDATA,YS) ; from YTQAPI8
+1 NEW N,N2,N4,R,S,YSAA,I,II,DFN,YSCODE,YSADATE,YSSCALE,YSBED,YSEND,YSED,YSET,YSR,YSSX,YSTN
+2 KILL YSDATA,YSSONE
+3 DO PARSE^YTAPI(.YS)
SCOR1 SET (YSTEST,YSET)=$ORDER(^YTT(601,"B",YSCODE,0))
+1 SET YSED=YSADATE
+2 SET YSDFN=DFN
+3 SET YSSX=$PIECE(^DPT(DFN,0),U,2)
+4 SET YSTN=YSCODE
+5 IF '$DATA(^YTD(601.2,YSDFN,1,YSET,1,YSED))
SET YSDATA(1)="[ERROR SCORE1+5]"
SET YSDATA(2)="no administration found"
QUIT
+6 ;check it
DO PRIV
+7 SET YSR(0)=$GET(^YTT(601.6,YSET,0))
+8 IF $PIECE(YSR(0),U,2)="Y"
SET X=^YTT(601.6,YSET,1)
XECUTE X
+9 if $GET(YSDATA(1))?1"[ERROR".E
QUIT
+10 DO SCORSET^YTAPI2
+11 if YSPRIV
DO SF^YTAPI2
+12 SET N1=0
+13 FOR
SET N1=$ORDER(YSSONE(N1))
if N1'>0
QUIT
SET N=N+1
SET YSDATA(N)=YSSONE(N1)
+14 DO CLEAN^YSMTI5
QUIT
PRIV ;check privileges
+1 NEW YS71,YSKEY
+2 SET YSPRIV=0
+3 SET YS71=$ORDER(^YTT(601.71,"B",YSTN,0))
+4 ;-->out error
if YS71'>0
QUIT
+5 SET YSKEY=$$GET1^DIQ(601.71,YS71_",",9)
+6 ;-->out exempt
IF YSKEY=""
SET YSPRIV=1
QUIT
+7 ;-->out has key
IF $DATA(^XUSEC(YSKEY,DUZ))
SET YSPRIV=1
QUIT
+8 QUIT
