ACRFDHRE ;IHS/OIRM/DSD/AEF - DHR ENTER/EDIT [ 11/01/2001 9:44 AM ]
;;2.1;ADMIN RESOURCE MGMT SYSTEM;;NOV 05, 2001
;
;
;This routine contains subroutines used to enter/edit DHR data in the
;DHR Data Records file. The subroutines are called by the ACRFDHRD
;routine.
;
OPT(ACROPT,ACROUT) ;EP
;----- SELECT WHICH TYPE OF DHRS TO ENTER
;
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="SOM^ARMS:ARMS DHR VERIFY/MODIFY/CLOSE;DHRD:DHR DATA ENTRY;CHCS:CORRECTION DHR'S FOR CHS (FY)"
S DIR("A")="Select DATA ENTRY OPTION"
D ^DIR
I $D(DIRUT)!($D(DTOUT))!($D(DUOUT)) S ACROUT=1 Q
I Y="" S ACROUT=1 Q
S ACROPT=$S(Y="DHRD":"1^2",Y="CHCS":"3^4",Y="ARMS":"5^6",1:"")
I ACROPT="" S ACROUT=1
Q
SEL(ACRD0,ACRD1,ACRD2,ACROUT,ACRADD,ACROPT,ACRCLR) ;EP
;----- SELECT BATCH
;
A ;
N Y
W !
D CLR(ACRADD,.Y,ACROPT,.ACROUT,.ACRCLR)
Q:$G(ACROUT)
S ACRD0=+Y
K Y
D DT(ACRD0,ACRADD,.Y,.ACROUT)
Q:$G(ACROUT)
S ACRD1=+Y
K Y
D ID(ACRD0,ACRD1,ACRADD,.Y,.ACROUT)
Q:$G(ACROUT)
S ACRD2=+Y
K Y
Q
DUPE(ACRD0,ACRD1,ACRD2,ACRD3,ACRDUP,ACRDR) ;EP
;----- PICK FIELDS TO DUPLICATE
;
N DATA,DIR,I,J,X,Y,Z
Q:'$D(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",ACRD3))
I '$G(ACRDUP) D
. S DIR(0)="Y"
. S DIR("A")="Do you want to duplicate fields"
. S DIR("B")="NO"
I $G(ACRDUP) D
. S DIR(0)="Y"
. S DIR("A")="Want to keep duplicating"
. S DIR("B")="YES"
D ^DIR
S ACRDUP=+Y
K DIR,X,Y
I 'ACRDUP K ACRDR Q
Q:$G(ACRDR)]""
S DIR(0)="FO"
S DIR("A")="Enter FIELD NUMBERS (2-28) you want to duplicate"
S DIR("?")="Enter which fields to duplicate, i.e., 2-10 or 2,3,5,18"
D ^DIR
K DIR
Q:Y']""
S ACRDR=""
S DATA=^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",ACRD3,0)
F I=1:1:$L(Y,",") D
. S Z=$P(Y,",",I)
. I Z["-" D Q
. . F J=$P(Z,"-"):1:$P(Z,"-",2) D
. . . Q:+J<2
. . . Q:+J>28
. . . S ACRDR=ACRDR_";"_J_"////"_$P(DATA,U,(J+1))
. Q:+Z<2
. Q:+Z>28
. S ACRDR=ACRDR_";"_Z_"////"_$P(DATA,U,(Z+1))
I $E(ACRDR)=";" S ACRDR=$E(ACRDR,2,999)
I ACRDR']"" K ACRDR
Q
TYPE(Y) ;EP -- SELECT RECORD TYPE
;
N DIR,DIRUT,DTOUT,DUOUT
S DIR(0)="SOM^2:BASIC TRANSACTION RECORD;3:CHANGE TRANSACTION RECORD;4:TRAILER RECORD;7:DFAFS RECORD;8:LOC(TRIBAL) TRANSACTION RECORD"
S DIR("A")="Select RECORD TYPE"
D ^DIR
I $D(DTOUT)!($D(DUOUT))!($D(DIRUT)) S Y=""
Q
CLR(ACRADD,Y,ACROPT,ACROUT,ACRCLR) ;
;----- LOOKUP BATCH COLOR TYPE
;
N DIC,DIR,DLAYGO,DTOUT,DUOUT,X
S DIC="^AFSHRCDS("
S DIC(0)=""
I $G(ACRCLR)']"" D
. S DIC(0)="AEMQ"
. S DIC("A")="Select BATCH TYPE/COLOR: "
I $G(ACRCLR)]"" D
. S X=$S(ACRCLR="B":$P(ACROPT,U),ACRCLR="R":$P(ACROPT,U,2),1:"")
. I X="" S ACROUT=1
Q:$G(ACROUT)
I $G(ACRADD) D
. S DIC(0)=DIC(0)_"L"
. S DLAYGO=9002322
D ^DIC
I $D(DTOUT)!($D(DUOUT)) S ACROUT=1
I Y'>0 S ACROUT=1
Q
RB(ACRCLR) ;EP
;----- SELECT RED OR BLUE BATCH
;
N DIR,DTOUT,DUOUT,X,Y
S DIR(0)="SBOM^B:BLUE;R:RED"
S DIR("A")="Select COLOR"
D ^DIR
I $D(DTOUT)!($D(DUOUT))!($D(DIRUT)) S ACROUT=1 Q
I Y="" S ACROUT=1 Q
S ACRCLR=Y
Q
DT(ACRD0,ACRADD,Y,ACROUT) ;
;----- LOOKUP BATCH DATE
;
N DA,DIC,DLAYGO,DTOUT,DUOUT,X
S DA(1)=ACRD0
S DIC="^AFSHRCDS("_DA(1)_","_"""D"""_","
S DIC(0)="AEMQ"
I $G(ACRADD) S DIC(0)=DIC(0)_"L"
S DIC("A")="Select BATCH DATE: "
S DIC("P")=$P(^DD(9002322,1,0),U,2)
I $G(ACRADD) S DLAYGO=9002322
D ^DIC
I $D(DUOUT)!($D(DTOUT)) S ACROUT=1
I +Y'>0 S ACROUT=1
Q
ID(ACRD0,ACRD1,ACRADD,Y,ACROUT) ;
;----- LOOKUP BATCH ID
;
N DA,DIC,DLAYGO,DTOUT,DUOUT,X
S DA(1)=ACRD1
S DA(2)=ACRD0
S DIC="^AFSHRCDS("_DA(2)_","_"""D"""_","_DA(1)_","_"""I"""_","
S DIC(0)="AEMQ"
I $G(ACRADD) S DIC(0)=DIC(0)_"L"
S DIC("A")="Select BATCH ID: "
S DIC("DR")=1
S DIC("P")=$P(^DD(9002322.02,1,0),U,2)
I $G(ACRADD) S DLAYGO=9002322.02
D ^DIC
I $D(DUOUT)!($D(DTOUT)) S ACROUT=1
I +Y'>0 S ACROUT=1
Q
SEQ(ACRD0,ACRD1,ACRD2,ACRDR,ACRADD,Y) ;EP
;----- LOOKUP BATCH SEQUENCE NUMBER
;
N DA,DIC,DLAYGO,DTOUT,DUOUT,X
I '$D(ACRTYPE) S ACRTYPE=2 ;Do Need this with 650 DHR
S DA(1)=ACRD2
S DA(2)=ACRD1
S DA(3)=ACRD0
S DIC="^AFSHRCDS("_DA(3)_","_"""D"""_","_DA(2)_","_"""I"""_","_DA(1)_","_"""S"""_","
S DIC(0)="AEMQ"
I $G(ACRADD) S DIC(0)=DIC(0)_"L"
S DIC("A")="Select SEQUENCE NUMBER ('^' to exit): "
S X=$P($G(^AFSHRCDS(DA(3),"D",DA(2),"I",DA(1),"S",0)),U,3)
F X=X+1 Q:'$D(^AFSHRCDS(DA(3),"D",DA(2),"I",DA(1),"S",X))
S DIC("B")=X
K X
S DIC("DR")="1////"_ACRTYPE
I $D(ACRDR) S DIC("DR")=DIC("DR")_";"_ACRDR
S DIC("P")=$P(^DD(9002322.21,6,0),U,2)
I $G(ACRADD) S DLAYGO=9002322.21
D ^DIC
I $D(DUOUT)!($D(DTOUT)) S Y=""
Q
EDIT(ACRD0,ACRD1,ACRD2,ACRD3,ACRTYPE,DDSPARM) ;EP
;----- EDIT SEQUENCE ENTRY
;
N DA,DDSFILE,DR
S DA=ACRD3
S DA(1)=ACRD2
S DA(2)=ACRD1
S DA(3)=ACRD0
S DDSFILE=9002322
S DDSFILE(1)=9002322.216
S DR=$S(ACRTYPE=3:"[ACR DHR ENTRY 3]",1:"[ACR DHR ENTRY 2]")
D ^DDS
Q
;
DEL(ACRD0,ACRD1,ACRD2,ACRD3,ACRTYPE) ;EP
;----- CHECK AND DELETE INCOMPLETE DHR SEQUENCE ENTRY
;
N DATA,DEL,I
S DEL=0
S DATA=^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",ACRD3,0)
I ACRTYPE=2 D
. F I=1:1:6,11:1:16 I $P(DATA,U,I)="" S DEL=1
I ACRTYPE=3 D
. F I=1,2,27 I $P(DATA,U,I)="" S DEL=1
I DEL D KILL(ACRD0,ACRD1,ACRD2,ACRD3)
Q
KILL(ACRD0,ACRD1,ACRD2,ACRD3) ;
;----- DELETE DHR SEQUENCE ENTRY
;
N DA,DIK
S DA(3)=ACRD0
S DA(2)=ACRD1
S DA(1)=ACRD2
S DA=ACRD3
S DIK="^AFSHRCDS("_DA(3)_","_"""D"""_","_DA(2)_","_"""I"""_","_DA(1)_","_"""S"""_","
D ^DIK
W *7," ",ACRD3," <DELETED>"
Q
HDR(D0,D1,D2) ;EP
;----- WRITE RECORD HEADER
;
N X,Z
I $G(D0)="" Q
I $G(D1)="" Q
I $G(D2)="" Q
S X="BID="
S Z=$P($G(^AFSHRCDS(D0,"D",D1,0)),U)
I Z S Z=$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_($E(Z,1,3)+1700)
S X=X_Z_"-"_$P(^AFSHRCDS(D0,"D",D1,"I",D2,0),U)
S X=X_" "
S Z=$P(^AFSHRCDS(D0,0),U)
S X=X_$S(Z=1!(Z=2):"PCC/HAS",Z=3!(Z=4):"CHS/FI",Z=5!(Z=6):"ARMS/HAS",1:"")
S X=X_" DHR INPUT RECORD (DETAIL) COLOR = "
S Z=$S(Z=1:"BLUE",Z=2:"RED",Z=3:"BLUE",Z=4:"RED",Z=5:"BLUE",Z=6:"RED",1:"")
S X=X_Z
Q X
TRAIL(ACRD0,ACRD1,ACRD2) ;EP
;----- ADD TRAILER RECORD
; Don't need this subroutine with 650 character DHRs
;
N AMT,CNT,DA,DATA,DIE,DIR,DR,X,Y
S (AMT,CNT,X)=0
F S X=$O(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",X)) Q:'X D
. S DATA=^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",X,0)
. S CNT=CNT+1
. S AMT=AMT+$P(DATA,U,15)
W !,"TRAILER DATA: RECORD COUNT = ",CNT," HASH DOLLARS = ",AMT
S DIR(0)="Y"
S DIR("A")="Is this correct"
S DIR("B")="NO"
D ^DIR
Q:'Y
S DA(2)=ACRD0
S DA(1)=ACRD1
S DA=ACRD2
S DIE="^AFSHRCDS("_DA(2)_","_"""D"""_","_DA(1)_","_"""I"""_","
S DR="2////CNT;4////"_CNT_";5////"_AMT
D ^DIE
W !,"TRAILER RECORD ADDED"
Q
RO ;EP -- CALLED FROM REOPEN BATCH OPTION
;
D HOME^%ZIS
D ^XBKVAR
S ACROUT=0
D DISPLAY^ACRFDHRD("1^6")
D SEL(.ACRD0,.ACRD1,.ACRD2,.ACROUT,0,"")
Q:$G(ACROUT)
I $P(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,0),U,3)'="C" D G RO
. W !," Batch is already OPEN"
. H 2
D REOPEN(ACRD0,ACRD1,ACRD2)
G RO
Q
REOPEN(ACRD0,ACRD1,ACRD2) ;EP
;----- REOPEN BATCH
;
N DA,DIE,DIR,DR,Y
S DA(2)=ACRD0
S DA(1)=ACRD1
S DA=ACRD2
S DIE="^AFSHRCDS("_DA(2)_","_"""D"""_","_DA(1)_","_"""I"""_","
S DR="2////@;3////@;4////@;5////@;8////@"
D ^DIE
W !," Batch reopened"
Q
DATE(X) ;EP -- FORMAT DATE
;
; X = INTERNAL FILEMANAGER DATE IN YYYMMDD FORMAT
N Y
S Y=""
I X D
. Q:$L(X)'=7
. S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_($E(X,1,3)+1700)
Q Y
ADDFMS(ACRD0,ACRD1,ACRD2,ACRD3,ACRSRC) ;EP
;----- ADD ENTRY TO FMS DOCUMENT HISTORY RECORD FILE
; FROM DHR DATA RECORDS FILE
;
N DA,DATA,DIC,DIE,DR,I,X,Y
Q:'$D(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",ACRD3,0))
Q:$G(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",ACRD3,99))
S DATA=^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",ACRD3,0)
S X=$P(DATA,U,8)
I X']"" S X=$P(DATA,10)
Q:X']""
K DD,DO
S DIC="^ACRDHR("
S DIC(0)=""
D FILE^DICN
Q:+Y'>0
S (ACRFMS,DA)=+Y
S DIE=DIC
S DR=".02////"_DT_";.03////"_$G(DUZ)_";202////"_$G(ACRSRC)
S X=""
F I=1:1:14 S X=X_I_"////"_$P(DATA,U,I)_";"
I $E(X,$L(X))=";" S X=$E(X,1,$L(X)-1)
S DR(1,9002189.1,1)=X
S X=""
F I=15:1:28 S X=X_I_"////"_$P(DATA,U,I)_";"
I $E(X,$L(X))=";" S X=$E(X,1,$L(X)-1)
S DR(1,9002189.1,2)=X
D ^DIE
;
K DR
S DA(3)=ACRD0
S DA(2)=ACRD1
S DA(1)=ACRD2
S DA=ACRD3
S DIE="^AFSHRCDS("_DA(3)_","_"""D"""_","_DA(2)_","_"""I"""_","_DA(1)_","_"""S"""_","
S DR="99////"_ACRFMS
D ^DIE
Q
LINK(DA,X1,X3,X4,X5,X6,X7) ;EP
;----- LINK FROM DHR DATA RECORDS FILE TO FMS DOCUMENT HISTORY RECORD
; FILE
;
; DA = IEN OF FMS DOCUMENT HISTORY RECORD FILE
; X1 = CORE TRANSMISSION DATE
; X3 = BATCH TYPE/COLOR
; X4 = BATCH DATE
; X5 = BATCH ID
; X6 = SEQUENCE NUMBER
; X7 = UNIX TRANSMISSION FILE NAME
;
N D0,D1,D2,D3,DIE,DR,X,Y
Q:'DA
S DIE="^ACRDHR("
S DR="201////"_X1_";203////"_X3_";204////"_X4_";205////"_X5_";206////"_X6_";207////"_X7
D ^DIE
Q
ACRFDHRE ;IHS/OIRM/DSD/AEF - DHR ENTER/EDIT [ 11/01/2001 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGMT SYSTEM;;NOV 05, 2001
+2 ;
+3 ;
+4 ;This routine contains subroutines used to enter/edit DHR data in the
+5 ;DHR Data Records file. The subroutines are called by the ACRFDHRD
+6 ;routine.
+7 ;
OPT(ACROPT,ACROUT) ;EP
+1 ;----- SELECT WHICH TYPE OF DHRS TO ENTER
+2 ;
+3 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+4 SET DIR(0)="SOM^ARMS:ARMS DHR VERIFY/MODIFY/CLOSE;DHRD:DHR DATA ENTRY;CHCS:CORRECTION DHR'S FOR CHS (FY)"
+5 SET DIR("A")="Select DATA ENTRY OPTION"
+6 DO ^DIR
+7 IF $DATA(DIRUT)!($DATA(DTOUT))!($DATA(DUOUT))
SET ACROUT=1
QUIT
+8 IF Y=""
SET ACROUT=1
QUIT
+9 SET ACROPT=$SELECT(Y="DHRD":"1^2",Y="CHCS":"3^4",Y="ARMS":"5^6",1:"")
+10 IF ACROPT=""
SET ACROUT=1
+11 QUIT
SEL(ACRD0,ACRD1,ACRD2,ACROUT,ACRADD,ACROPT,ACRCLR) ;EP
+1 ;----- SELECT BATCH
+2 ;
A ;
+1 NEW Y
+2 WRITE !
+3 DO CLR(ACRADD,.Y,ACROPT,.ACROUT,.ACRCLR)
+4 IF $GET(ACROUT)
QUIT
+5 SET ACRD0=+Y
+6 KILL Y
+7 DO DT(ACRD0,ACRADD,.Y,.ACROUT)
+8 IF $GET(ACROUT)
QUIT
+9 SET ACRD1=+Y
+10 KILL Y
+11 DO ID(ACRD0,ACRD1,ACRADD,.Y,.ACROUT)
+12 IF $GET(ACROUT)
QUIT
+13 SET ACRD2=+Y
+14 KILL Y
+15 QUIT
DUPE(ACRD0,ACRD1,ACRD2,ACRD3,ACRDUP,ACRDR) ;EP
+1 ;----- PICK FIELDS TO DUPLICATE
+2 ;
+3 NEW DATA,DIR,I,J,X,Y,Z
+4 IF '$DATA(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",ACRD3))
QUIT
+5 IF '$GET(ACRDUP)
Begin DoDot:1
+6 SET DIR(0)="Y"
+7 SET DIR("A")="Do you want to duplicate fields"
+8 SET DIR("B")="NO"
End DoDot:1
+9 IF $GET(ACRDUP)
Begin DoDot:1
+10 SET DIR(0)="Y"
+11 SET DIR("A")="Want to keep duplicating"
+12 SET DIR("B")="YES"
End DoDot:1
+13 DO ^DIR
+14 SET ACRDUP=+Y
+15 KILL DIR,X,Y
+16 IF 'ACRDUP
KILL ACRDR
QUIT
+17 IF $GET(ACRDR)]""
QUIT
+18 SET DIR(0)="FO"
+19 SET DIR("A")="Enter FIELD NUMBERS (2-28) you want to duplicate"
+20 SET DIR("?")="Enter which fields to duplicate, i.e., 2-10 or 2,3,5,18"
+21 DO ^DIR
+22 KILL DIR
+23 IF Y']""
QUIT
+24 SET ACRDR=""
+25 SET DATA=^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",ACRD3,0)
+26 FOR I=1:1:$LENGTH(Y,",")
Begin DoDot:1
+27 SET Z=$PIECE(Y,",",I)
+28 IF Z["-"
Begin DoDot:2
+29 FOR J=$PIECE(Z,"-"):1:$PIECE(Z,"-",2)
Begin DoDot:3
+30 IF +J<2
QUIT
+31 IF +J>28
QUIT
+32 SET ACRDR=ACRDR_";"_J_"////"_$PIECE(DATA,U,(J+1))
End DoDot:3
End DoDot:2
QUIT
+33 IF +Z<2
QUIT
+34 IF +Z>28
QUIT
+35 SET ACRDR=ACRDR_";"_Z_"////"_$PIECE(DATA,U,(Z+1))
End DoDot:1
+36 IF $EXTRACT(ACRDR)=";"
SET ACRDR=$EXTRACT(ACRDR,2,999)
+37 IF ACRDR']""
KILL ACRDR
+38 QUIT
TYPE(Y) ;EP -- SELECT RECORD TYPE
+1 ;
+2 NEW DIR,DIRUT,DTOUT,DUOUT
+3 SET DIR(0)="SOM^2:BASIC TRANSACTION RECORD;3:CHANGE TRANSACTION RECORD;4:TRAILER RECORD;7:DFAFS RECORD;8:LOC(TRIBAL) TRANSACTION RECORD"
+4 SET DIR("A")="Select RECORD TYPE"
+5 DO ^DIR
+6 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
SET Y=""
+7 QUIT
CLR(ACRADD,Y,ACROPT,ACROUT,ACRCLR) ;
+1 ;----- LOOKUP BATCH COLOR TYPE
+2 ;
+3 NEW DIC,DIR,DLAYGO,DTOUT,DUOUT,X
+4 SET DIC="^AFSHRCDS("
+5 SET DIC(0)=""
+6 IF $GET(ACRCLR)']""
Begin DoDot:1
+7 SET DIC(0)="AEMQ"
+8 SET DIC("A")="Select BATCH TYPE/COLOR: "
End DoDot:1
+9 IF $GET(ACRCLR)]""
Begin DoDot:1
+10 SET X=$SELECT(ACRCLR="B":$PIECE(ACROPT,U),ACRCLR="R":$PIECE(ACROPT,U,2),1:"")
+11 IF X=""
SET ACROUT=1
End DoDot:1
+12 IF $GET(ACROUT)
QUIT
+13 IF $GET(ACRADD)
Begin DoDot:1
+14 SET DIC(0)=DIC(0)_"L"
+15 SET DLAYGO=9002322
End DoDot:1
+16 DO ^DIC
+17 IF $DATA(DTOUT)!($DATA(DUOUT))
SET ACROUT=1
+18 IF Y'>0
SET ACROUT=1
+19 QUIT
RB(ACRCLR) ;EP
+1 ;----- SELECT RED OR BLUE BATCH
+2 ;
+3 NEW DIR,DTOUT,DUOUT,X,Y
+4 SET DIR(0)="SBOM^B:BLUE;R:RED"
+5 SET DIR("A")="Select COLOR"
+6 DO ^DIR
+7 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
SET ACROUT=1
QUIT
+8 IF Y=""
SET ACROUT=1
QUIT
+9 SET ACRCLR=Y
+10 QUIT
DT(ACRD0,ACRADD,Y,ACROUT) ;
+1 ;----- LOOKUP BATCH DATE
+2 ;
+3 NEW DA,DIC,DLAYGO,DTOUT,DUOUT,X
+4 SET DA(1)=ACRD0
+5 SET DIC="^AFSHRCDS("_DA(1)_","_"""D"""_","
+6 SET DIC(0)="AEMQ"
+7 IF $GET(ACRADD)
SET DIC(0)=DIC(0)_"L"
+8 SET DIC("A")="Select BATCH DATE: "
+9 SET DIC("P")=$PIECE(^DD(9002322,1,0),U,2)
+10 IF $GET(ACRADD)
SET DLAYGO=9002322
+11 DO ^DIC
+12 IF $DATA(DUOUT)!($DATA(DTOUT))
SET ACROUT=1
+13 IF +Y'>0
SET ACROUT=1
+14 QUIT
ID(ACRD0,ACRD1,ACRADD,Y,ACROUT) ;
+1 ;----- LOOKUP BATCH ID
+2 ;
+3 NEW DA,DIC,DLAYGO,DTOUT,DUOUT,X
+4 SET DA(1)=ACRD1
+5 SET DA(2)=ACRD0
+6 SET DIC="^AFSHRCDS("_DA(2)_","_"""D"""_","_DA(1)_","_"""I"""_","
+7 SET DIC(0)="AEMQ"
+8 IF $GET(ACRADD)
SET DIC(0)=DIC(0)_"L"
+9 SET DIC("A")="Select BATCH ID: "
+10 SET DIC("DR")=1
+11 SET DIC("P")=$PIECE(^DD(9002322.02,1,0),U,2)
+12 IF $GET(ACRADD)
SET DLAYGO=9002322.02
+13 DO ^DIC
+14 IF $DATA(DUOUT)!($DATA(DTOUT))
SET ACROUT=1
+15 IF +Y'>0
SET ACROUT=1
+16 QUIT
SEQ(ACRD0,ACRD1,ACRD2,ACRDR,ACRADD,Y) ;EP
+1 ;----- LOOKUP BATCH SEQUENCE NUMBER
+2 ;
+3 NEW DA,DIC,DLAYGO,DTOUT,DUOUT,X
+4 ;Do Need this with 650 DHR
IF '$DATA(ACRTYPE)
SET ACRTYPE=2
+5 SET DA(1)=ACRD2
+6 SET DA(2)=ACRD1
+7 SET DA(3)=ACRD0
+8 SET DIC="^AFSHRCDS("_DA(3)_","_"""D"""_","_DA(2)_","_"""I"""_","_DA(1)_","_"""S"""_","
+9 SET DIC(0)="AEMQ"
+10 IF $GET(ACRADD)
SET DIC(0)=DIC(0)_"L"
+11 SET DIC("A")="Select SEQUENCE NUMBER ('^' to exit): "
+12 SET X=$PIECE($GET(^AFSHRCDS(DA(3),"D",DA(2),"I",DA(1),"S",0)),U,3)
+13 FOR X=X+1
IF '$DATA(^AFSHRCDS(DA(3),"D",DA(2),"I",DA(1),"S",X))
QUIT
+14 SET DIC("B")=X
+15 KILL X
+16 SET DIC("DR")="1////"_ACRTYPE
+17 IF $DATA(ACRDR)
SET DIC("DR")=DIC("DR")_";"_ACRDR
+18 SET DIC("P")=$PIECE(^DD(9002322.21,6,0),U,2)
+19 IF $GET(ACRADD)
SET DLAYGO=9002322.21
+20 DO ^DIC
+21 IF $DATA(DUOUT)!($DATA(DTOUT))
SET Y=""
+22 QUIT
EDIT(ACRD0,ACRD1,ACRD2,ACRD3,ACRTYPE,DDSPARM) ;EP
+1 ;----- EDIT SEQUENCE ENTRY
+2 ;
+3 NEW DA,DDSFILE,DR
+4 SET DA=ACRD3
+5 SET DA(1)=ACRD2
+6 SET DA(2)=ACRD1
+7 SET DA(3)=ACRD0
+8 SET DDSFILE=9002322
+9 SET DDSFILE(1)=9002322.216
+10 SET DR=$SELECT(ACRTYPE=3:"[ACR DHR ENTRY 3]",1:"[ACR DHR ENTRY 2]")
+11 DO ^DDS
+12 QUIT
+13 ;
DEL(ACRD0,ACRD1,ACRD2,ACRD3,ACRTYPE) ;EP
+1 ;----- CHECK AND DELETE INCOMPLETE DHR SEQUENCE ENTRY
+2 ;
+3 NEW DATA,DEL,I
+4 SET DEL=0
+5 SET DATA=^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",ACRD3,0)
+6 IF ACRTYPE=2
Begin DoDot:1
+7 FOR I=1:1:6,11:1:16
IF $PIECE(DATA,U,I)=""
SET DEL=1
End DoDot:1
+8 IF ACRTYPE=3
Begin DoDot:1
+9 FOR I=1,2,27
IF $PIECE(DATA,U,I)=""
SET DEL=1
End DoDot:1
+10 IF DEL
DO KILL(ACRD0,ACRD1,ACRD2,ACRD3)
+11 QUIT
KILL(ACRD0,ACRD1,ACRD2,ACRD3) ;
+1 ;----- DELETE DHR SEQUENCE ENTRY
+2 ;
+3 NEW DA,DIK
+4 SET DA(3)=ACRD0
+5 SET DA(2)=ACRD1
+6 SET DA(1)=ACRD2
+7 SET DA=ACRD3
+8 SET DIK="^AFSHRCDS("_DA(3)_","_"""D"""_","_DA(2)_","_"""I"""_","_DA(1)_","_"""S"""_","
+9 DO ^DIK
+10 WRITE *7," ",ACRD3," <DELETED>"
+11 QUIT
HDR(D0,D1,D2) ;EP
+1 ;----- WRITE RECORD HEADER
+2 ;
+3 NEW X,Z
+4 IF $GET(D0)=""
QUIT
+5 IF $GET(D1)=""
QUIT
+6 IF $GET(D2)=""
QUIT
+7 SET X="BID="
+8 SET Z=$PIECE($GET(^AFSHRCDS(D0,"D",D1,0)),U)
+9 IF Z
SET Z=$EXTRACT(Z,4,5)_"/"_$EXTRACT(Z,6,7)_"/"_($EXTRACT(Z,1,3)+1700)
+10 SET X=X_Z_"-"_$PIECE(^AFSHRCDS(D0,"D",D1,"I",D2,0),U)
+11 SET X=X_" "
+12 SET Z=$PIECE(^AFSHRCDS(D0,0),U)
+13 SET X=X_$SELECT(Z=1!(Z=2):"PCC/HAS",Z=3!(Z=4):"CHS/FI",Z=5!(Z=6):"ARMS/HAS",1:"")
+14 SET X=X_" DHR INPUT RECORD (DETAIL) COLOR = "
+15 SET Z=$SELECT(Z=1:"BLUE",Z=2:"RED",Z=3:"BLUE",Z=4:"RED",Z=5:"BLUE",Z=6:"RED",1:"")
+16 SET X=X_Z
+17 QUIT X
TRAIL(ACRD0,ACRD1,ACRD2) ;EP
+1 ;----- ADD TRAILER RECORD
+2 ; Don't need this subroutine with 650 character DHRs
+3 ;
+4 NEW AMT,CNT,DA,DATA,DIE,DIR,DR,X,Y
+5 SET (AMT,CNT,X)=0
+6 FOR
SET X=$ORDER(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",X))
IF 'X
QUIT
Begin DoDot:1
+7 SET DATA=^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",X,0)
+8 SET CNT=CNT+1
+9 SET AMT=AMT+$PIECE(DATA,U,15)
End DoDot:1
+10 WRITE !,"TRAILER DATA: RECORD COUNT = ",CNT," HASH DOLLARS = ",AMT
+11 SET DIR(0)="Y"
+12 SET DIR("A")="Is this correct"
+13 SET DIR("B")="NO"
+14 DO ^DIR
+15 IF 'Y
QUIT
+16 SET DA(2)=ACRD0
+17 SET DA(1)=ACRD1
+18 SET DA=ACRD2
+19 SET DIE="^AFSHRCDS("_DA(2)_","_"""D"""_","_DA(1)_","_"""I"""_","
+20 SET DR="2////CNT;4////"_CNT_";5////"_AMT
+21 DO ^DIE
+22 WRITE !,"TRAILER RECORD ADDED"
+23 QUIT
RO ;EP -- CALLED FROM REOPEN BATCH OPTION
+1 ;
+2 DO HOME^%ZIS
+3 DO ^XBKVAR
+4 SET ACROUT=0
+5 DO DISPLAY^ACRFDHRD("1^6")
+6 DO SEL(.ACRD0,.ACRD1,.ACRD2,.ACROUT,0,"")
+7 IF $GET(ACROUT)
QUIT
+8 IF $PIECE(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,0),U,3)'="C"
Begin DoDot:1
+9 WRITE !," Batch is already OPEN"
+10 HANG 2
End DoDot:1
GOTO RO
+11 DO REOPEN(ACRD0,ACRD1,ACRD2)
+12 GOTO RO
+13 QUIT
REOPEN(ACRD0,ACRD1,ACRD2) ;EP
+1 ;----- REOPEN BATCH
+2 ;
+3 NEW DA,DIE,DIR,DR,Y
+4 SET DA(2)=ACRD0
+5 SET DA(1)=ACRD1
+6 SET DA=ACRD2
+7 SET DIE="^AFSHRCDS("_DA(2)_","_"""D"""_","_DA(1)_","_"""I"""_","
+8 SET DR="2////@;3////@;4////@;5////@;8////@"
+9 DO ^DIE
+10 WRITE !," Batch reopened"
+11 QUIT
DATE(X) ;EP -- FORMAT DATE
+1 ;
+2 ; X = INTERNAL FILEMANAGER DATE IN YYYMMDD FORMAT
+3 NEW Y
+4 SET Y=""
+5 IF X
Begin DoDot:1
+6 IF $LENGTH(X)'=7
QUIT
+7 SET Y=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_($EXTRACT(X,1,3)+1700)
End DoDot:1
+8 QUIT Y
ADDFMS(ACRD0,ACRD1,ACRD2,ACRD3,ACRSRC) ;EP
+1 ;----- ADD ENTRY TO FMS DOCUMENT HISTORY RECORD FILE
+2 ; FROM DHR DATA RECORDS FILE
+3 ;
+4 NEW DA,DATA,DIC,DIE,DR,I,X,Y
+5 IF '$DATA(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",ACRD3,0))
QUIT
+6 IF $GET(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",ACRD3,99))
QUIT
+7 SET DATA=^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",ACRD3,0)
+8 SET X=$PIECE(DATA,U,8)
+9 IF X']""
SET X=$PIECE(DATA,10)
+10 IF X']""
QUIT
+11 KILL DD,DO
+12 SET DIC="^ACRDHR("
+13 SET DIC(0)=""
+14 DO FILE^DICN
+15 IF +Y'>0
QUIT
+16 SET (ACRFMS,DA)=+Y
+17 SET DIE=DIC
+18 SET DR=".02////"_DT_";.03////"_$GET(DUZ)_";202////"_$GET(ACRSRC)
+19 SET X=""
+20 FOR I=1:1:14
SET X=X_I_"////"_$PIECE(DATA,U,I)_";"
+21 IF $EXTRACT(X,$LENGTH(X))=";"
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+22 SET DR(1,9002189.1,1)=X
+23 SET X=""
+24 FOR I=15:1:28
SET X=X_I_"////"_$PIECE(DATA,U,I)_";"
+25 IF $EXTRACT(X,$LENGTH(X))=";"
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+26 SET DR(1,9002189.1,2)=X
+27 DO ^DIE
+28 ;
+29 KILL DR
+30 SET DA(3)=ACRD0
+31 SET DA(2)=ACRD1
+32 SET DA(1)=ACRD2
+33 SET DA=ACRD3
+34 SET DIE="^AFSHRCDS("_DA(3)_","_"""D"""_","_DA(2)_","_"""I"""_","_DA(1)_","_"""S"""_","
+35 SET DR="99////"_ACRFMS
+36 DO ^DIE
+37 QUIT
LINK(DA,X1,X3,X4,X5,X6,X7) ;EP
+1 ;----- LINK FROM DHR DATA RECORDS FILE TO FMS DOCUMENT HISTORY RECORD
+2 ; FILE
+3 ;
+4 ; DA = IEN OF FMS DOCUMENT HISTORY RECORD FILE
+5 ; X1 = CORE TRANSMISSION DATE
+6 ; X3 = BATCH TYPE/COLOR
+7 ; X4 = BATCH DATE
+8 ; X5 = BATCH ID
+9 ; X6 = SEQUENCE NUMBER
+10 ; X7 = UNIX TRANSMISSION FILE NAME
+11 ;
+12 NEW D0,D1,D2,D3,DIE,DR,X,Y
+13 IF 'DA
QUIT
+14 SET DIE="^ACRDHR("
+15 SET DR="201////"_X1_";203////"_X3_";204////"_X4_";205////"_X5_";206////"_X6_";207////"_X7
+16 DO ^DIE
+17 QUIT
