DGRUASIH ; ALB/GRR - RAI/MDS ASIH BACKGROUND JOB ; 11-1-00
;;5.3;Registration;**328,371,373,424,1015**;Aug 13, 1993;Build 21
EN ;Main Entry Point
;
Q:'$D(^DGRU(46.14,"AD","A")) ;No patients on ASIH
;Look for ASIH date/times which have exceeded 30 days
N DGASIHDT,DFN,DGIEN,DGDT,DGCDT
D NOW^%DTC S DGCDT=% ;set to current date/time
S DGDT=""
F S DGDT=$O(^DGRU(46.14,"AD","A",DGDT)) Q:DGDT=""!(DGDT>DGCDT) D
.S DFN=0 F S DFN=$O(^DGRU(46.14,"AD","A",DGDT,DFN)) Q:DFN="" D
..S DGIEN=$O(^DGRU(46.14,"AD","A",DGDT,DFN,0))
..S DGASIHDT=$P($G(^DGRU(46.14,DFN,1,DGIEN,0)),"^")
..S X1=DGASIHDT,X2=30 D C^%DTC S DGEVDT=X
..S DGPMDT=DGASIHDT-.000001 ;to get inpatient info for movement prior to asih
..S DGRSLT=$$BLDA03(DFN,DGEVDT,DGPMDT)
..D UPSTAT(DFN,DGIEN,"I")
MQUIT Q
;
UPSTAT(DFN,DGIEN,DGSTAT) ;
;DFN - Patient internal entry number
;DGIEN - Entry number in RAI MDS ASIH Patient file
;DGSTAT - New status
S DA=DGIEN,DA(1)=DFN,DR=".04///^S X=DGSTAT",(DIC,DIE)="^DGRU(46.14,"_DFN_",1," D ^DIE
Q
;
BLDA03(DFN,DGEVDT,DGPMDT) ;BUILD A03 DISCHARGE MESSAGE
S DGREF="^TMP(""HLS"","_$J_")"
K @DGREF
D INIT^HLFNC2("DGRU-RAI-A03-SERVER",.HL) ;changed p-371
I ($O(HL(""))']"") S RESULT="-1^Server Protocol not found" G BLDQ
;
S VAIP("D")=DGPMDT D IN5^VADPT S DGMIEN=VAIP(1)
;N DGTEMP
N DGASIH S DGASIH=2 D EN^DGRUGA03(DFN,DGMIEN,"DGTEMP")
I '$O(DGTEMP(0)) S RESULT="-1^Unable to build segment list" G BLDQ
;
;Check segment list for errors
N I S I=0
F S I=$O(DGTEMP(I)) Q:'I D G:(+$G(RESULT)<0) BLDQ
.I +DGTEMP(I)<0 S RESULT="-1^Error while building segment"
;
M @DGREF=DGTEMP
S RESULT=$$SENDMSG(DGREF)
I +$P(RESULT,"^",2)>0 S RESULT="-1^"_$P(RESULT,"^",2,3)
BLDQ Q $G(RESULT)
;
SENDMSG(DGARRAY) ;TRANSMIT HL7 MESSAGE
N HLA,HLRST
M HLA("HLS")=@DGARRAY
I $D(HLA("HLS")) D
.D GENERATE^HLMA("DGRU-RAI-A03-SERVER","LM",1,.HLRST,"") ;changed p-371
K HLA,HERR
Q (HLRST)
;
ADDASIH(DFN,DGASIHDT) ;ADD AN ASIH FOR A PATIENT
;
N DGSTAT,DIC,DR,X,DINUM S DGSTAT="A"
I '$D(^DGRU(46.14,DFN)) D
.S DIC="^DGRU(46.14,",DIC(0)="LN",X=DFN,DINUM=DFN D FILE^DICN
S DA(1)=DFN,DIC="^DGRU(46.14,"_DFN_",1,",DIC(0)="L",X=DGASIHDT,DIC("DR")=".04///^S X=DGSTAT" D ^DIC
Q
;
ADDRDT(DFN,DGASIHDT) ;ADD RETURN DATE FROM ASIH
;
N DGSTAT,DA S DGSTAT="I"
S DA=$O(^DGRU(46.14,"AC",DFN,"A",0)) Q:DA=""
N DIC,DR,DIE
S DA(1)=DFN,DIC="^DGRU(46.14,"_DFN_",1,",DIE=DIC,DR=".02///^S X=DGASIHDT;.04///^S X=DGSTAT" D ^DIE
Q
;
DELASIH(DFN,DGASIHDT) ;DELETE ASIH EPISODE
;
N DA,DIC,DIK
S DA(1)=DFN,DA=$O(^DGRU(46.14,DFN,1,"B",DGASIHDT,0)) Q:DA=""
S DIK="^DGRU(46.14,"_DFN_",1," D ^DIK
Q
;
CHANGDT(DFN,DGODT,DGNDT) ;CHANGE TO ASIH DATE/TIME
N DA,DIE,DR
S DA(1)=DFN,DA=$O(^DGRU(46.14,DFN,1,"B",DGODT,0)) Q:DA=""
S DIE="^DGRU(46.14,"_DFN_",1,",DR=".01///^S X=DGNDT" D ^DIE
Q
;
DGRUASIH ; ALB/GRR - RAI/MDS ASIH BACKGROUND JOB ; 11-1-00
+1 ;;5.3;Registration;**328,371,373,424,1015**;Aug 13, 1993;Build 21
EN ;Main Entry Point
+1 ;
+2 ;No patients on ASIH
IF '$DATA(^DGRU(46.14,"AD","A"))
QUIT
+3 ;Look for ASIH date/times which have exceeded 30 days
+4 NEW DGASIHDT,DFN,DGIEN,DGDT,DGCDT
+5 ;set to current date/time
DO NOW^%DTC
SET DGCDT=%
+6 SET DGDT=""
+7 FOR
SET DGDT=$ORDER(^DGRU(46.14,"AD","A",DGDT))
IF DGDT=""!(DGDT>DGCDT)
QUIT
Begin DoDot:1
+8 SET DFN=0
FOR
SET DFN=$ORDER(^DGRU(46.14,"AD","A",DGDT,DFN))
IF DFN=""
QUIT
Begin DoDot:2
+9 SET DGIEN=$ORDER(^DGRU(46.14,"AD","A",DGDT,DFN,0))
+10 SET DGASIHDT=$PIECE($GET(^DGRU(46.14,DFN,1,DGIEN,0)),"^")
+11 SET X1=DGASIHDT
SET X2=30
DO C^%DTC
SET DGEVDT=X
+12 ;to get inpatient info for movement prior to asih
SET DGPMDT=DGASIHDT-.000001
+13 SET DGRSLT=$$BLDA03(DFN,DGEVDT,DGPMDT)
+14 DO UPSTAT(DFN,DGIEN,"I")
End DoDot:2
End DoDot:1
MQUIT QUIT
+1 ;
UPSTAT(DFN,DGIEN,DGSTAT) ;
+1 ;DFN - Patient internal entry number
+2 ;DGIEN - Entry number in RAI MDS ASIH Patient file
+3 ;DGSTAT - New status
+4 SET DA=DGIEN
SET DA(1)=DFN
SET DR=".04///^S X=DGSTAT"
SET (DIC,DIE)="^DGRU(46.14,"_DFN_",1,"
DO ^DIE
+5 QUIT
+6 ;
BLDA03(DFN,DGEVDT,DGPMDT) ;BUILD A03 DISCHARGE MESSAGE
+1 SET DGREF="^TMP(""HLS"","_$JOB_")"
+2 KILL @DGREF
+3 ;changed p-371
DO INIT^HLFNC2("DGRU-RAI-A03-SERVER",.HL)
+4 IF ($ORDER(HL(""))']"")
SET RESULT="-1^Server Protocol not found"
GOTO BLDQ
+5 ;
+6 SET VAIP("D")=DGPMDT
DO IN5^VADPT
SET DGMIEN=VAIP(1)
+7 ;N DGTEMP
+8 NEW DGASIH
SET DGASIH=2
DO EN^DGRUGA03(DFN,DGMIEN,"DGTEMP")
+9 IF '$ORDER(DGTEMP(0))
SET RESULT="-1^Unable to build segment list"
GOTO BLDQ
+10 ;
+11 ;Check segment list for errors
+12 NEW I
SET I=0
+13 FOR
SET I=$ORDER(DGTEMP(I))
IF 'I
QUIT
Begin DoDot:1
+14 IF +DGTEMP(I)<0
SET RESULT="-1^Error while building segment"
End DoDot:1
IF (+$GET(RESULT)<0)
GOTO BLDQ
+15 ;
+16 MERGE @DGREF=DGTEMP
+17 SET RESULT=$$SENDMSG(DGREF)
+18 IF +$PIECE(RESULT,"^",2)>0
SET RESULT="-1^"_$PIECE(RESULT,"^",2,3)
BLDQ QUIT $GET(RESULT)
+1 ;
SENDMSG(DGARRAY) ;TRANSMIT HL7 MESSAGE
+1 NEW HLA,HLRST
+2 MERGE HLA("HLS")=@DGARRAY
+3 IF $DATA(HLA("HLS"))
Begin DoDot:1
+4 ;changed p-371
DO GENERATE^HLMA("DGRU-RAI-A03-SERVER","LM",1,.HLRST,"")
End DoDot:1
+5 KILL HLA,HERR
+6 QUIT (HLRST)
+7 ;
ADDASIH(DFN,DGASIHDT) ;ADD AN ASIH FOR A PATIENT
+1 ;
+2 NEW DGSTAT,DIC,DR,X,DINUM
SET DGSTAT="A"
+3 IF '$DATA(^DGRU(46.14,DFN))
Begin DoDot:1
+4 SET DIC="^DGRU(46.14,"
SET DIC(0)="LN"
SET X=DFN
SET DINUM=DFN
DO FILE^DICN
End DoDot:1
+5 SET DA(1)=DFN
SET DIC="^DGRU(46.14,"_DFN_",1,"
SET DIC(0)="L"
SET X=DGASIHDT
SET DIC("DR")=".04///^S X=DGSTAT"
DO ^DIC
+6 QUIT
+7 ;
ADDRDT(DFN,DGASIHDT) ;ADD RETURN DATE FROM ASIH
+1 ;
+2 NEW DGSTAT,DA
SET DGSTAT="I"
+3 SET DA=$ORDER(^DGRU(46.14,"AC",DFN,"A",0))
IF DA=""
QUIT
+4 NEW DIC,DR,DIE
+5 SET DA(1)=DFN
SET DIC="^DGRU(46.14,"_DFN_",1,"
SET DIE=DIC
SET DR=".02///^S X=DGASIHDT;.04///^S X=DGSTAT"
DO ^DIE
+6 QUIT
+7 ;
DELASIH(DFN,DGASIHDT) ;DELETE ASIH EPISODE
+1 ;
+2 NEW DA,DIC,DIK
+3 SET DA(1)=DFN
SET DA=$ORDER(^DGRU(46.14,DFN,1,"B",DGASIHDT,0))
IF DA=""
QUIT
+4 SET DIK="^DGRU(46.14,"_DFN_",1,"
DO ^DIK
+5 QUIT
+6 ;
CHANGDT(DFN,DGODT,DGNDT) ;CHANGE TO ASIH DATE/TIME
+1 NEW DA,DIE,DR
+2 SET DA(1)=DFN
SET DA=$ORDER(^DGRU(46.14,DFN,1,"B",DGODT,0))
IF DA=""
QUIT
+3 SET DIE="^DGRU(46.14,"_DFN_",1,"
SET DR=".01///^S X=DGNDT"
DO ^DIE
+4 QUIT
+5 ;
