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

YTQAPI14.m

Go to the documentation of this file.
  1. 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
  1. Q
  1. ;Reference to ^XUSEC( supported by DBIA #10076
  1. ;Reference to ^DPT( supported by DBIA #10035
  1. ;Reference to ^PXRMINDX(601.84, supported by DBIA #4290
  1. ;Reference to FILE 870 supported by DBIA #5603
  1. RESEND ;resend all no transmits and errors
  1. N YSDATE,YSAD,YSTS,YSFILT,YSBEG,YSEND,YSSNDFLG
  1. W @IOF,!,"MHA3 HL7 Resends",!!,"CAUTION:: use only if instructed by National Support Staff",!
  1. K DIR S DIR(0)="Y",DIR("B")="No",DIR("A")="Continue" D ^DIR Q:$D(DIRUT)
  1. Q:Y=0
  1. K DIR S DIR(0)="D^:DT:EX",DIR("A")="Begin Date" D ^DIR Q:$D(DIRUT)
  1. S YSBEG=Y
  1. K DIR S DIR(0)="D^"_Y_":DT:EX",DIR("A")="End Date" D ^DIR Q:$D(DIRUT)
  1. S YSEND=Y
  1. 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)
  1. S YSFILT=Y
  1. S YSCODE=0,N1=0 F S YSCODE=$O(^YTT(601.84,"AC",YSCODE)) Q:YSCODE'>0 D
  1. . S YSSNDFLG=$P($G(^YTT(601.71,YSCODE,8)),U,4)
  1. . Q:YSSNDFLG'="Y"
  1. . S YSDATE=YSBEG,YSEND=YSEND+.9
  1. . F S YSDATE=$O(^YTT(601.84,"AC",YSCODE,YSDATE)) Q:YSDATE'>0!(YSDATE>YSEND) D
  1. .. S YSAD=0 F S YSAD=$O(^YTT(601.84,"AC",YSCODE,YSDATE,YSAD)) Q:YSAD'>0 D Q
  1. ... S YSTS=$P($G(^YTT(601.84,YSAD,2)),U)
  1. ... Q:YSTS="" ;-->out never send --incomplete
  1. ... I YSFILT="E" Q:YSTS'="E"
  1. ... I YSFILT="T" Q:YSTS'="T"
  1. ... I YSFILT="B" Q:(YSTS'="E")&(YSTS'="T")
  1. ... D NULLNOW
  1. ... K YS,YSDATA S YS("AD")=YSAD D HL7^YTQHL7(.YSDATA,.YS)
  1. ... S N1=N1+1 ;W !,N1," ",YSAD," date=",YSDATE," stat= ",YSTS
  1. W !,N1," messages resent"
  1. Q
  1. NULLNOW ;set transmission status to "" and NOW
  1. N DIE,DR,DA
  1. S DA=YSAD,DIE="^YTT(601.84,",DR="11////@;12///NOW"
  1. NN1 ;re-entry if lock fails
  1. L +^YTT(601.84,DA):DILOCKTM I '$T H 10 G NN1
  1. D ^DIE
  1. L -^YTT(601.84,DA)
  1. Q
  1. CKHL7 ;check hl7 status
  1. N DIC,DA
  1. W @IOF,!?15,"*** HL7 Check ***",!
  1. S X="YS MHAT",DIC=870 D ^DIC
  1. I +Y'>0 W !,"YS MHAT ERROR" Q ;-->out
  1. S DA=+Y D EN^DIQ
  1. S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Continue" D ^DIR Q:$D(DIRUT)
  1. Q:Y=0
  1. D SELADM^YTQAPI14(.YSAD)
  1. Q:YSAD'>0 ;-->out
  1. S DIC="^YTT(601.84,",DA=YSAD D EN^DIQ
  1. Q
  1. SEND1 ;send single HL7 by pt & test
  1. N DIC,YSAD
  1. D SELADM^YTQAPI14(.YSAD)
  1. Q:YSAD'>0
  1. K YS,YSDATA
  1. D NULLNOW
  1. S YS("AD")=YSAD D HL7^YTQHL7(.YSDATA,.YS)
  1. W !,"HL7 message created..."
  1. Q
  1. SELADM(YSADIEN) ;select admin by pt and test
  1. N N,YSGIVEN,DIC,DFN,YSCODEN,YSDFN,YTTLKUP
  1. S YSADIEN=0,YTTLKUP=1 ; suppress filter
  1. D ^YSLRP Q:YSDFN'>0
  1. S DIC="^YTT(601.71,",DIC(0)="AEQ" D ^DIC Q:Y'>0
  1. S YSCODEN=+Y
  1. S YSGIVEN=0
  1. F S YSGIVEN=$O(^PXRMINDX(601.84,"PI",YSDFN,YSCODEN,YSGIVEN)) Q:YSGIVEN'>0 D
  1. . S N=0 F S N=$O(^PXRMINDX(601.84,"PI",DFN,YSCODEN,YSGIVEN,N)) Q:N'>0 D
  1. .. W !,N
  1. .. S Y=YSGIVEN D DD^%DT W ?15,Y
  1. S DIC="^YTT(601.84,",DIC(0)="AEQ" D ^DIC
  1. S YSADIEN=+Y
  1. Q
  1. NOPNOTE ;entry point for YTQ PNOTE FLAG option
  1. N DIE,DIC,X,Y,DA,DR,YTTLKUP
  1. S YTTLKUP=1 ; suppress filter
  1. S DIC="^YTT(601.71,",DIC(0)="AEMQ" D ^DIC Q:Y'>0
  1. S DIE="^YTT(601.71,",DA=+Y,DR="28;29;30" D ^DIE
  1. I $G(DA) D NEWDATE^YTXCHGU(DA) ; so GUI will pick up the change
  1. Q
  1. EXEMPT ;exempt by adim and report
  1. N DIE,DIC,X,Y,DA,DR,YTTLKUP
  1. W @IOF,!,"*** Exempt Test ***",!!
  1. 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.",!!
  1. S YTTLKUP=1 ; suppress filter
  1. S DIC="^YTT(601.71,",DIC(0)="AEMQ" D ^DIC Q:Y'>0
  1. S DIE="^YTT(601.71,",DA=+Y,DR="8;9;27;18///NOW" D ^DIE
  1. Q
  1. SIGNOK(YSDATA,YS) ;entry point for YTQ ASI SIGNOK rpc
  1. ;Input: IENS as iens for 604
  1. ;Output: 1^OK TO SIGN
  1. ; 0^MISSING REQUIRED FIELDS
  1. ; 2^A G12 RECORD
  1. N N1,YSASCLS,X,YSASFLD,YSF,YSN,YSFLAG,YSIEN,YSTYPE
  1. S YSFLAG=1
  1. S YSIEN=$G(YS("IENS"),-1)
  1. I '$D(^YSTX(604,YSIEN,0)) S YSDATA(1)="[ERROR]",YSDATA(2)="BAD IEN" Q
  1. S YSDATA(1)="[DATA]",YSDATA(2)="1^OK TO SIGN"
  1. S YSN=2
  1. S YSASCLS=$$GET1^DIQ(604,YSIEN_",",.04,"I")
  1. S YSASCLS=YSASCLS+3
  1. 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)))
  1. . S YSASFLD=$P(^YSTX(604.66,N1,0),U,3)
  1. . D TYPE
  1. . S YSF=$S(YSASFLD>10.02&(YSASFLD<10.44):"I",YSTYPE=1:"",1:"I")
  1. . S X=$$GET1^DIQ(604,YSIEN,YSASFLD,YSF)
  1. . S:X="" YSFLAG=0,YSN=YSN+1,YSDATA(YSN)=^YSTX(604.66,N1,0)
  1. S X=$$GET1^DIQ(604,YSIEN,YSASFLD,.11)
  1. S:X="X"!(X="N") YSFLAG=2
  1. S:YSFLAG=0 YSDATA(2)="0^MISSING REQUIRED FIELDS"
  1. S:YSFLAG=2 YSDATA(2)="2^A G12 RECORD"
  1. Q
  1. TYPE ;check field type
  1. ;O = NOT A POINTER 1 = POINTER
  1. N YSFLD
  1. S YSTYPE=0
  1. D FIELD^DID(604,YSASFLD,"","TYPE","YSFLD")
  1. S:YSFLD("TYPE")="POINTER" YSTYPE=1
  1. Q
  1. SCOREIT(YSDATA,YS) ; from YTQAPI8
  1. N N,N2,N4,R,S,YSAA,I,II,DFN,YSCODE,YSADATE,YSSCALE,YSBED,YSEND,YSED,YSET,YSR,YSSX,YSTN
  1. K YSDATA,YSSONE
  1. D PARSE^YTAPI(.YS)
  1. SCOR1 S (YSTEST,YSET)=$O(^YTT(601,"B",YSCODE,0))
  1. S YSED=YSADATE
  1. S YSDFN=DFN
  1. S YSSX=$P(^DPT(DFN,0),U,2)
  1. S YSTN=YSCODE
  1. IF '$D(^YTD(601.2,YSDFN,1,YSET,1,YSED)) S YSDATA(1)="[ERROR SCORE1+5]",YSDATA(2)="no administration found" Q
  1. D PRIV ;check it
  1. S YSR(0)=$G(^YTT(601.6,YSET,0))
  1. I $P(YSR(0),U,2)="Y" S X=^YTT(601.6,YSET,1) X X
  1. Q:$G(YSDATA(1))?1"[ERROR".E
  1. D SCORSET^YTAPI2
  1. D:YSPRIV SF^YTAPI2
  1. S N1=0
  1. F S N1=$O(YSSONE(N1)) Q:N1'>0 S N=N+1,YSDATA(N)=YSSONE(N1)
  1. D CLEAN^YSMTI5 Q
  1. PRIV ;check privileges
  1. N YS71,YSKEY
  1. S YSPRIV=0
  1. S YS71=$O(^YTT(601.71,"B",YSTN,0))
  1. Q:YS71'>0 ;-->out error
  1. S YSKEY=$$GET1^DIQ(601.71,YS71_",",9)
  1. I YSKEY="" S YSPRIV=1 Q ;-->out exempt
  1. I $D(^XUSEC(YSKEY,DUZ)) S YSPRIV=1 Q ;-->out has key
  1. Q