- 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 Feb 18, 2025@23:44:27 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