AGHL7 ; IHS/ASDS/EFG -- LOOP THROUGH XTMP USING DFN ;
;;7.1;PATIENT REGISTRATION;**9**;AUG 25,2005
;
START ;EP-HL7 CALL
NEW DFN,INDA,DZ2,AGDUZ2
S DZ2="" F S DZ2=$O(^XTMP("AGHL7",DZ2)) Q:DZ2="" S DFN="" F S DFN=$O(^XTMP("AGHL7",DZ2,DFN)) Q:+DFN=0 D
.L +^XTMP("AGHL7",DZ2,DFN):0 Q:'$T
. S X=$O(^XTMP("AGHL7",DZ2,DFN,"")),X="AG "_X_" A PATIENT",DIC=101,INDA=DFN,AGDUZ2=DZ2
. D EN^XQOR
.K ^XTMP("AGHL7",DZ2,DFN)
.L -^XTMP("AGHL7",DZ2,DFN)
Q
; PROGRAMMERS NOTE:
; THIS ROUTINE IS CALLED, FROM THE TOP, BY A BHL ROUTINE, WITHOUT
; ANY AGREEMENT AMONG PACKAGES OR DEVELOPERS. TO PREVENT BREAKING
; THE BHL ROUTINE, ANOTHER ENTRY POINT FOR THE AGMENU OPTION IS
; CREATED, BELOW, AND THE ABOVE CODE WILL REMAIN UNCHANGED.
; George T. Huggins, June 2002
;
; The AG entry point is called from the Exit Action field of the
; AGMENU option.
;
; Variable DFN is KILL'd by KILL^AG, called from the Exit Action field
; of the AGMENU option.
;
; B/c of the spaghetti-code nature of AG, a Patient could be marked as
; having been updated during the entry of the patient as a new Patient.
;
; The REGISTER/UPDATE locations in AG mark the ^XTMP global as:
; ^XTMP("AGHL7AG",SITE,1234,"REGISTER")=""
; ^XTMP("AGHL7AG",SITE,1234,"UPDATE")=""
; so the SET'ing of X will get "REGISTER" -if- both have occured, and
; -only- invoke the "AG REGISTER A PATIENT" protocol.
;
AG ;EP - From AGMENU, EXIT ACTION.
NEW DFN,DZ2,INDA,AGDFN,AGDUZ2
S DZ2="" F S DZ2=$O(^XTMP("AGHL7AG",DZ2)) Q:DZ2="" D
. S DFN="" F S DFN=$O(^XTMP("AGHL7AG",DZ2,DFN)) Q:+DFN=0 D
.. LOCK +^XTMP("AGHL7AG",DZ2,DFN):0
.. E Q
.. S X=$O(^XTMP("AGHL7AG",DZ2,DFN,"")),X="AG "_X_" A PATIENT",DIC=101,(AGDFN,INDA)=DFN,AGDUZ2=DZ2
.. D EN^XQOR
.. KILL ^XTMP("AGHL7AG",DZ2,DFN)
.. LOCK -^XTMP("AGHL7AG",DZ2,DFN)
Q
XPORT ;EP - From TaskMan for regular xport.
NEW AGDUZ2,AGTIME,AGQUIT,AGTXBDT,AGTXDATE,DFN,DIC,INDA
S AGTIME=$$NOW^XLFDT
W:'$D(ZTQUEUED) !,"Beginning Regular Xport @ ",$$FMTE^XLFDT(AGTIME)
;Check if regular export run today. If so, quit.
;>>> need code
I '$G(DUZ(2)) S DUZ(2)=$P(^AUTTSITE(1,0),U)
S AGDUZ2=DUZ(2)
KILL ^TMP("AGHL7",$J,"REGULAR XPORT")
W:'$D(ZTQUEUED) !,"Determining start date..."
;If nothing in ag message file, get seed from agtxst. This'll be like an RG export: send all adds/edits from the date of the last export, thru -yesterday-.
I '$O(^AGTXMSG(0)) D I 1
. NEW AGTXSITE,AGLIEN
. S AGTXSITE=$P(^AUTTSITE(1,0),U)
. D AGR1^AGTXST
. S AGTXBDT=$S($G(AGLIEN):$P(^AGTXST(AGTXSITE,1,AGLIEN,0),U,3),1:0),AGTXBDT=$P(AGTXBDT,".",1)
. ;AGTXBDT is ready to go.
.Q
E D
. S %=$P(^AGTXMSG(0),U,3)+1
. ;Backup and find the first regular xport.
. F S %=$O(^AGTXMSG(%),-1) Q:'% I $P(^(%,0),U,3)="X" Q
. ;We have to subtract a day.
. S AGTXBDT=$S(%:$P($P(^AGTXMSG(%,0),U),".",1),1:0),AGTXBDT=$$FMADD^XLFDT(""_AGTXBDT_"",-1)
.Q
W:'$D(ZTQUEUED) $$FMTE^XLFDT(AGTXBDT)
;Check for NEW pats in ^aupnpat, keep track, enter in ag message.
;
W:'$D(ZTQUEUED) !,"Checking for NEW Patients...",!
S AGTXDATE=AGTXBDT
F S AGTXDATE=$O(^AUPNPAT("ADTE",AGTXDATE)) Q:('AGTXDATE)!(AGTXDATE=DT) D
. S DFN=0
. F S DFN=$O(^AUPNPAT("ADTE",AGTXDATE,DFN)) Q:'DFN D
.. W:'$D(ZTQUEUED) $J(DFN,8)
.. D GEN("REGISTER","X",DFN)
.. SET ^TMP("AGHL7",$J,"REGULAR XPORT",DFN,"REGISTER")=""
..Q
.Q
;Check for edited pats in ^aupnpat. dont's send update if register.
W:'$D(ZTQUEUED) !,"Checking for EDITED Patients...",!
S DFN=0
F S DFN=$O(^AUPNPAT(DFN)) Q:+DFN=0 D
. Q:'($P(^AUPNPAT(DFN,0),U,3)>AGTXBDT) ;edit must be after seed date.
. Q:$P(^AUPNPAT(DFN,0),U,3)=DT ;edit is TODAY.
. Q:$P(^DPT(DFN,0),U,19) ;merged pt
. Q:$D(^TMP("AGHL7",$J,"REGULAR XPORT",DFN,"REGISTER"))
. S (AGQUIT,DUZ(2))=0
. F S DUZ(2)=$O(^AUPNPAT(DFN,41,DUZ(2))) Q:'DUZ(2) D Q:AGQUIT
.. Q:'$D(^AGFAC("AC",DUZ(2))) ; ORF
.. I $L($P(^AUPNPAT(DFN,41,DUZ(2),0),U,5)) Q:"DM"[$P(^(0),U,5) ; deleted or merged patient
.. W:'$D(ZTQUEUED) $J(DFN,8)
.. D GEN("UPDATE","X",DFN)
.. S AGQUIT=1
..Q
.Q
S DUZ(2)=AGDUZ2
KILL ^TMP("AGHL7",$J,"REGULAR XPORT")
;check for ACKs for all previous messages.
D MSGIDS
;re-q xport task
;>>>need code
;
S $P(AGTIME,U,2)=$$NOW^XLFDT
Q:$D(ZTQUEUED)
W !,"Ending Regular Xport @ ",$$FMTE^XLFDT($P(AGTIME,U,2)),!,"Elapsed time: ",$S($P(AGTIME,U,2)=$P(AGTIME,U):"Less than a second.",1:$$FMDIFF^XLFDT($P(AGTIME,U,2),$P(AGTIME,U,1),3))
I $$DIR^XBDIR("E")
Q
REGALL ;EP - From menu.
;; This option sends a "REGISTER" message to the Integration Engine
;; for all active Patients in your database.
;;
;;###
D HELP^XBHELP("REGALL","AGHL7")
Q:'$$DIR^XBDIR("YO","Proceed","N","","Do you want to proceed and send a ""REGISTER"" message for all Pat's to the IE (Y/N)")
NEW AG4,AGB,AGC,AGE,AGDUZ2,DFN,DIC,INDA
S AGB=$$NOW^XLFDT
W !,"Begin at ",$$FMTE^XLFDT(AGB),"."
S AGDUZ2=DUZ(2),DFN=0,AG4=$P(^AUPNPAT(0),U,4),AGC=0
W !,AG4," Patients",!
F S DFN=$O(^AUPNPAT(DFN)) Q:+DFN=0 D
. Q:'$D(^DPT(DFN))
. Q:$P(^DPT(DFN,0),U,19) ;merged pt
. S DUZ(2)=0
. F S DUZ(2)=$O(^AUPNPAT(DFN,41,DUZ(2))) Q:'DUZ(2) D
.. Q:'$D(^AGFAC("AC",DUZ(2))) ;ORF
.. I $L($P(^AUPNPAT(DFN,41,DUZ(2),0),U,5)) Q:"DM"[$P(^(0),U,5) ; deleted or merged patient
.. D GEN("REGISTER","A",DFN)
..Q
. S AGC=AGC+1
. I '(AGC#100) W " | ",$J(AGC/AG4*100,0,0),"%"
.Q
S DUZ(2)=AGDUZ2
S AGE=$$NOW^XLFDT
W !," End at ",$$FMTE^XLFDT(AGE),"."
W !,"Elapsed time: ",$$FMDIFF^XLFDT(AGE,AGB,3)
I $$DIR^XBDIR("E","Done. Press RETURN")
Q
GEN(AGTYPE,AGCAUSE,INDA) ;
NEW DA,DIC,DR,INHF,X
S X="AG "_AGTYPE_" A PATIENT",DIC=101
D EN^XQOR
D TXMSG(DFN,AGTYPE,AGCAUSE,INHF)
Q
TXMSG(DFN,AGTYPE,AGCAUSE,INHF) ;make entry into agtxmsg
NEW DA,DIC,DR,X
S X=$$NOW^XLFDT,AGTYPE=$S(AGTYPE="REGISTER":"A28",AGTYPE="UPDATE":"A08",1:"Z00")
KILL DD,DO,DIC,DA,DR
S DIC="^AGTXMSG(",DIC(0)="L",DIC("DR")=".02////"_DFN_";.03///"_AGCAUSE_";.04////2600101;.05////2600101;.06///H;.07///"_AGTYPE_";.08////"_INHF
D FILE^DICN
Q
MSGIDS ;TM a job to update date/time msg sent, ack received.
S ZTRTN="MSGIDSTM^AGHL7",ZTIO="",ZTDESC="Update AG MESSAGE TRANSACTONS file.",ZTDTH=$H,ZTDTH=$$HADD^XLFDT($H,0,0,30,0)
D ^%ZTLOAD
Q
MSGIDSTM ;EP - from TaskMan.
NEW AGIEN,AGXREF,DA,DIC,DIE,DR,X
F AGXREF="D","E" D
. S AGIEN=0
. F S AGIEN=$O(^AGTXMSG("D",2600101,AGIEN)) Q:'AGIEN D
.. S X="IHS-"_$P(^AGTXMSG(AGIEN,0),U,8),DIC="^INTHU(",DIC(0)="",D="C"
.. D IX^DIC
.. Q:'(+Y>0)
.. S DIE="^AGTXMSG(",DA=AGIEN,DR=".04////"_$P(Y,U,2)
.. I $P(^INTHU(DA,0),U,18) S DR=DR_";.05////"_$P(^INTHU($P(^INTHU(DA,0),U,18),0),U,1)
.. D ^DIE
..Q
.Q
S ZTREQ="@"
Q
AGHL7 ; IHS/ASDS/EFG -- LOOP THROUGH XTMP USING DFN ;
+1 ;;7.1;PATIENT REGISTRATION;**9**;AUG 25,2005
+2 ;
START ;EP-HL7 CALL
+1 NEW DFN,INDA,DZ2,AGDUZ2
+2 SET DZ2=""
FOR
SET DZ2=$ORDER(^XTMP("AGHL7",DZ2))
IF DZ2=""
QUIT
SET DFN=""
FOR
SET DFN=$ORDER(^XTMP("AGHL7",DZ2,DFN))
IF +DFN=0
QUIT
Begin DoDot:1
+3 LOCK +^XTMP("AGHL7",DZ2,DFN):0
IF '$TEST
QUIT
+4 SET X=$ORDER(^XTMP("AGHL7",DZ2,DFN,""))
SET X="AG "_X_" A PATIENT"
SET DIC=101
SET INDA=DFN
SET AGDUZ2=DZ2
+5 DO EN^XQOR
+6 KILL ^XTMP("AGHL7",DZ2,DFN)
+7 LOCK -^XTMP("AGHL7",DZ2,DFN)
End DoDot:1
+8 QUIT
+9 ; PROGRAMMERS NOTE:
+10 ; THIS ROUTINE IS CALLED, FROM THE TOP, BY A BHL ROUTINE, WITHOUT
+11 ; ANY AGREEMENT AMONG PACKAGES OR DEVELOPERS. TO PREVENT BREAKING
+12 ; THE BHL ROUTINE, ANOTHER ENTRY POINT FOR THE AGMENU OPTION IS
+13 ; CREATED, BELOW, AND THE ABOVE CODE WILL REMAIN UNCHANGED.
+14 ; George T. Huggins, June 2002
+15 ;
+16 ; The AG entry point is called from the Exit Action field of the
+17 ; AGMENU option.
+18 ;
+19 ; Variable DFN is KILL'd by KILL^AG, called from the Exit Action field
+20 ; of the AGMENU option.
+21 ;
+22 ; B/c of the spaghetti-code nature of AG, a Patient could be marked as
+23 ; having been updated during the entry of the patient as a new Patient.
+24 ;
+25 ; The REGISTER/UPDATE locations in AG mark the ^XTMP global as:
+26 ; ^XTMP("AGHL7AG",SITE,1234,"REGISTER")=""
+27 ; ^XTMP("AGHL7AG",SITE,1234,"UPDATE")=""
+28 ; so the SET'ing of X will get "REGISTER" -if- both have occured, and
+29 ; -only- invoke the "AG REGISTER A PATIENT" protocol.
+30 ;
AG ;EP - From AGMENU, EXIT ACTION.
+1 NEW DFN,DZ2,INDA,AGDFN,AGDUZ2
+2 SET DZ2=""
FOR
SET DZ2=$ORDER(^XTMP("AGHL7AG",DZ2))
IF DZ2=""
QUIT
Begin DoDot:1
+3 SET DFN=""
FOR
SET DFN=$ORDER(^XTMP("AGHL7AG",DZ2,DFN))
IF +DFN=0
QUIT
Begin DoDot:2
+4 LOCK +^XTMP("AGHL7AG",DZ2,DFN):0
+5 IF '$TEST
QUIT
+6 SET X=$ORDER(^XTMP("AGHL7AG",DZ2,DFN,""))
SET X="AG "_X_" A PATIENT"
SET DIC=101
SET (AGDFN,INDA)=DFN
SET AGDUZ2=DZ2
+7 DO EN^XQOR
+8 KILL ^XTMP("AGHL7AG",DZ2,DFN)
+9 LOCK -^XTMP("AGHL7AG",DZ2,DFN)
End DoDot:2
End DoDot:1
+10 QUIT
XPORT ;EP - From TaskMan for regular xport.
+1 NEW AGDUZ2,AGTIME,AGQUIT,AGTXBDT,AGTXDATE,DFN,DIC,INDA
+2 SET AGTIME=$$NOW^XLFDT
+3 IF '$DATA(ZTQUEUED)
WRITE !,"Beginning Regular Xport @ ",$$FMTE^XLFDT(AGTIME)
+4 ;Check if regular export run today. If so, quit.
+5 ;>>> need code
+6 IF '$GET(DUZ(2))
SET DUZ(2)=$PIECE(^AUTTSITE(1,0),U)
+7 SET AGDUZ2=DUZ(2)
+8 KILL ^TMP("AGHL7",$JOB,"REGULAR XPORT")
+9 IF '$DATA(ZTQUEUED)
WRITE !,"Determining start date..."
+10 ;If nothing in ag message file, get seed from agtxst. This'll be like an RG export: send all adds/edits from the date of the last export, thru -yesterday-.
+11 IF '$ORDER(^AGTXMSG(0))
Begin DoDot:1
+12 NEW AGTXSITE,AGLIEN
+13 SET AGTXSITE=$PIECE(^AUTTSITE(1,0),U)
+14 DO AGR1^AGTXST
+15 SET AGTXBDT=$SELECT($GET(AGLIEN):$PIECE(^AGTXST(AGTXSITE,1,AGLIEN,0),U,3),1:0)
SET AGTXBDT=$PIECE(AGTXBDT,".",1)
+16 ;AGTXBDT is ready to go.
+17 QUIT
End DoDot:1
IF 1
+18 IF '$TEST
Begin DoDot:1
+19 SET %=$PIECE(^AGTXMSG(0),U,3)+1
+20 ;Backup and find the first regular xport.
+21 FOR
SET %=$ORDER(^AGTXMSG(%),-1)
IF '%
QUIT
IF $PIECE(^(%,0),U,3)="X"
QUIT
+22 ;We have to subtract a day.
+23 SET AGTXBDT=$SELECT(%:$PIECE($PIECE(^AGTXMSG(%,0),U),".",1),1:0)
SET AGTXBDT=$$FMADD^XLFDT(""_AGTXBDT_"",-1)
+24 QUIT
End DoDot:1
+25 IF '$DATA(ZTQUEUED)
WRITE $$FMTE^XLFDT(AGTXBDT)
+26 ;Check for NEW pats in ^aupnpat, keep track, enter in ag message.
+27 ;
+28 IF '$DATA(ZTQUEUED)
WRITE !,"Checking for NEW Patients...",!
+29 SET AGTXDATE=AGTXBDT
+30 FOR
SET AGTXDATE=$ORDER(^AUPNPAT("ADTE",AGTXDATE))
IF ('AGTXDATE)!(AGTXDATE=DT)
QUIT
Begin DoDot:1
+31 SET DFN=0
+32 FOR
SET DFN=$ORDER(^AUPNPAT("ADTE",AGTXDATE,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+33 IF '$DATA(ZTQUEUED)
WRITE $JUSTIFY(DFN,8)
+34 DO GEN("REGISTER","X",DFN)
+35 SET ^TMP("AGHL7",$JOB,"REGULAR XPORT",DFN,"REGISTER")=""
+36 QUIT
End DoDot:2
+37 QUIT
End DoDot:1
+38 ;Check for edited pats in ^aupnpat. dont's send update if register.
+39 IF '$DATA(ZTQUEUED)
WRITE !,"Checking for EDITED Patients...",!
+40 SET DFN=0
+41 FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF +DFN=0
QUIT
Begin DoDot:1
+42 ;edit must be after seed date.
IF '($PIECE(^AUPNPAT(DFN,0),U,3)>AGTXBDT)
QUIT
+43 ;edit is TODAY.
IF $PIECE(^AUPNPAT(DFN,0),U,3)=DT
QUIT
+44 ;merged pt
IF $PIECE(^DPT(DFN,0),U,19)
QUIT
+45 IF $DATA(^TMP("AGHL7",$JOB,"REGULAR XPORT",DFN,"REGISTER"))
QUIT
+46 SET (AGQUIT,DUZ(2))=0
+47 FOR
SET DUZ(2)=$ORDER(^AUPNPAT(DFN,41,DUZ(2)))
IF 'DUZ(2)
QUIT
Begin DoDot:2
+48 ; ORF
IF '$DATA(^AGFAC("AC",DUZ(2)))
QUIT
+49 ; deleted or merged patient
IF $LENGTH($PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,5))
IF "DM"[$PIECE(^(0),U,5)
QUIT
+50 IF '$DATA(ZTQUEUED)
WRITE $JUSTIFY(DFN,8)
+51 DO GEN("UPDATE","X",DFN)
+52 SET AGQUIT=1
+53 QUIT
End DoDot:2
IF AGQUIT
QUIT
+54 QUIT
End DoDot:1
+55 SET DUZ(2)=AGDUZ2
+56 KILL ^TMP("AGHL7",$JOB,"REGULAR XPORT")
+57 ;check for ACKs for all previous messages.
+58 DO MSGIDS
+59 ;re-q xport task
+60 ;>>>need code
+61 ;
+62 SET $PIECE(AGTIME,U,2)=$$NOW^XLFDT
+63 IF $DATA(ZTQUEUED)
QUIT
+64 WRITE !,"Ending Regular Xport @ ",$$FMTE^XLFDT($PIECE(AGTIME,U,2)),!,"Elapsed time: ",$SELECT($PIECE(AGTIME,U,2)=$PIECE(AGTIME,U):"Less than a second.",1:$$FMDIFF^XLFDT($PIECE(AGTIME,U,2),$PIECE(AGTIME,U,1),3))
+65 IF $$DIR^XBDIR("E")
+66 QUIT
REGALL ;EP - From menu.
+1 ;; This option sends a "REGISTER" message to the Integration Engine
+2 ;; for all active Patients in your database.
+3 ;;
+4 ;;###
+5 DO HELP^XBHELP("REGALL","AGHL7")
+6 IF '$$DIR^XBDIR("YO","Proceed","N","","Do you want to proceed and send a ""REGISTER"" message for all Pat's to the IE (Y/N)")
QUIT
+7 NEW AG4,AGB,AGC,AGE,AGDUZ2,DFN,DIC,INDA
+8 SET AGB=$$NOW^XLFDT
+9 WRITE !,"Begin at ",$$FMTE^XLFDT(AGB),"."
+10 SET AGDUZ2=DUZ(2)
SET DFN=0
SET AG4=$PIECE(^AUPNPAT(0),U,4)
SET AGC=0
+11 WRITE !,AG4," Patients",!
+12 FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF +DFN=0
QUIT
Begin DoDot:1
+13 IF '$DATA(^DPT(DFN))
QUIT
+14 ;merged pt
IF $PIECE(^DPT(DFN,0),U,19)
QUIT
+15 SET DUZ(2)=0
+16 FOR
SET DUZ(2)=$ORDER(^AUPNPAT(DFN,41,DUZ(2)))
IF 'DUZ(2)
QUIT
Begin DoDot:2
+17 ;ORF
IF '$DATA(^AGFAC("AC",DUZ(2)))
QUIT
+18 ; deleted or merged patient
IF $LENGTH($PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,5))
IF "DM"[$PIECE(^(0),U,5)
QUIT
+19 DO GEN("REGISTER","A",DFN)
+20 QUIT
End DoDot:2
+21 SET AGC=AGC+1
+22 IF '(AGC#100)
WRITE " | ",$JUSTIFY(AGC/AG4*100,0,0),"%"
+23 QUIT
End DoDot:1
+24 SET DUZ(2)=AGDUZ2
+25 SET AGE=$$NOW^XLFDT
+26 WRITE !," End at ",$$FMTE^XLFDT(AGE),"."
+27 WRITE !,"Elapsed time: ",$$FMDIFF^XLFDT(AGE,AGB,3)
+28 IF $$DIR^XBDIR("E","Done. Press RETURN")
+29 QUIT
GEN(AGTYPE,AGCAUSE,INDA) ;
+1 NEW DA,DIC,DR,INHF,X
+2 SET X="AG "_AGTYPE_" A PATIENT"
SET DIC=101
+3 DO EN^XQOR
+4 DO TXMSG(DFN,AGTYPE,AGCAUSE,INHF)
+5 QUIT
TXMSG(DFN,AGTYPE,AGCAUSE,INHF) ;make entry into agtxmsg
+1 NEW DA,DIC,DR,X
+2 SET X=$$NOW^XLFDT
SET AGTYPE=$SELECT(AGTYPE="REGISTER":"A28",AGTYPE="UPDATE":"A08",1:"Z00")
+3 KILL DD,DO,DIC,DA,DR
+4 SET DIC="^AGTXMSG("
SET DIC(0)="L"
SET DIC("DR")=".02////"_DFN_";.03///"_AGCAUSE_";.04////2600101;.05////2600101;.06///H;.07///"_AGTYPE_";.08////"_INHF
+5 DO FILE^DICN
+6 QUIT
MSGIDS ;TM a job to update date/time msg sent, ack received.
+1 SET ZTRTN="MSGIDSTM^AGHL7"
SET ZTIO=""
SET ZTDESC="Update AG MESSAGE TRANSACTONS file."
SET ZTDTH=$HOROLOG
SET ZTDTH=$$HADD^XLFDT($HOROLOG,0,0,30,0)
+2 DO ^%ZTLOAD
+3 QUIT
MSGIDSTM ;EP - from TaskMan.
+1 NEW AGIEN,AGXREF,DA,DIC,DIE,DR,X
+2 FOR AGXREF="D","E"
Begin DoDot:1
+3 SET AGIEN=0
+4 FOR
SET AGIEN=$ORDER(^AGTXMSG("D",2600101,AGIEN))
IF 'AGIEN
QUIT
Begin DoDot:2
+5 SET X="IHS-"_$PIECE(^AGTXMSG(AGIEN,0),U,8)
SET DIC="^INTHU("
SET DIC(0)=""
SET D="C"
+6 DO IX^DIC
+7 IF '(+Y>0)
QUIT
+8 SET DIE="^AGTXMSG("
SET DA=AGIEN
SET DR=".04////"_$PIECE(Y,U,2)
+9 IF $PIECE(^INTHU(DA,0),U,18)
SET DR=DR_";.05////"_$PIECE(^INTHU($PIECE(^INTHU(DA,0),U,18),0),U,1)
+10 DO ^DIE
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 SET ZTREQ="@"
+14 QUIT
