ACHSYCS ; IHS/ITSC/PMF - RETRANSMIT BY TRANSACTION CODE AND DATE RANGE ; [ 12/06/2002 10:36 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5**;JUN 11, 2001
;IHS/SET/GTH ACHS*3.1*5 12/06/2002
;IHS/DSD/CS;2991001;FIND ALL OF A TYPE OF TRANSITION AND RETRANSMIT
;
;Variables Used
; ZCS1=BATCH DATE (?)
; ZCS1S=START DATE
; ZCS1E=END DATE
; ZCS2=TYPE
; ZCS3=DOCUMENT IEN
; ZCS4=TRANSACTION IEN
;
BEGIN ;
;TEST FOR EXISTANCE OF DATA
I '$D(^ACHSF(DUZ(2),"TB")) W *7,!!,*7,"No data to process. Quiting." Q
S (ZCS1,ZCS1S,ZCS1E,ZCS2,ZCS3,ZCS4,ZCS5)=""
;
;GET TRANSACTION TYPE
K DIR
S DIR(0)="F^1:2^K:X'?.U X"
S DIR("A",1)="Select Transaction Type:"
S DIR("A",2)=" C Cancelation"
S DIR("A",3)=" I Initial"
S DIR("A",4)=" P Payment"
S DIR("A",5)=" IP Intrim Payment"
S DIR("A",6)=" ZA Adjustment"
S DIR("A")="Select C, I, P, IP, or ZA: "
S DIR("B")="C"
D ^DIR
Q:X=""
S ZCS2=X
;
BDATE ;GET START DATE
N DIR,Y
W !!
S DIR(0)="DO^::EX"
S DIR("A")="Enter Start Date: "
D ^DIR
I Y="" W *7," No date supplyed. Terminating." Q
I Y>DT W *7," NO FUTURE DATES ALLOWED" G BDATE
S ZCS1S=Y
;
EDATE ;GET END DATE
N DIR,Y
W !
S DIR(0)="DO^::EX"
S DIR("A")="Enter End Date: "
S DIR("B")=ZCS1S
D ^DIR
I Y="" W *7," No date supplyed. Returning to Start Date Entry." G BDATE
I Y>DT W *7," NO FUTURE DATES ALLOWED" G EDATE
I Y<ZCS1S W *7," Ending date must be after beginning date." G EDATE
S ZCS1E=Y
;
PROC ;ACTUAL PROCESSING STARTS HERE
S ZCS1=ZCS1S-1
F S ZCS1=$O(^ACHSF(DUZ(2),"TB",ZCS1)) Q:ZCS1>ZCS1E!(ZCS1="") D
.Q:'$D(^ACHSF(DUZ(2),"TB",ZCS1,ZCS2))
.S ZCS3=""
.F S ZCS3=$O(^ACHSF(DUZ(2),"TB",ZCS1,ZCS2,ZCS3)) Q:ZCS3="" D
..S ZCS4=""
..F S ZCS4=$O(^ACHSF(DUZ(2),"TB",ZCS1,ZCS2,ZCS3,ZCS4)) Q:ZCS4="" D
...;IF PROMPTING IS REQUIRED BEFORE CLEARING, IT GOES HERE.
...I ZCS2="C",$P(^ACHSF(DUZ(2),"D",ZCS3,"T",ZCS4,0),U,5)'="F" Q ; NOT FULL
...S ^TMP("ACHSTXAR",$J,ZCS1,ZCS3,ZCS4)=""
...S ZCS5=1
; GO AND TRANSMIT THIS DATA NOW
S ACHSIO=IO ; JUST BECAUSE WE WANT TO
S ACHSARCO=$P(^ACHSF(DUZ(2),0),U,11) ; AREA CONTRACTING NUMBER
;I +ACHSARCO<1!($L(ACHSARCO)'=3) D G EXIT ; CAN'T CONTINUE W/O THIS;IHS/SET/GTH ACHS*3.1*5 12/06/2002
;. W !,"MISSING AREA CONTRACTING NUMBER - JOB ABBORTING";IHS/SET/GTH ACHS*3.1*5 12/06/2002
I '(ACHSARCO?3UN) U IO(0) W *7,!!,"Area Contracting Number is not 3 Upper-case Alpha-Numerics",!,"JOB CANCELLED" G EXIT ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
;
S ACHSRCT=0 ; INITIALIZE RECORD COUNTER
;
;pmf 6/6/1 add next line. init the re-export flag to NO.
S ACHSREEX=0
D:ZCS5 ^ACHSTXA1
;
EXIT ; PUT CLEANUP STUFF HERE IF NEEDED
Q
ACHSYCS ; IHS/ITSC/PMF - RETRANSMIT BY TRANSACTION CODE AND DATE RANGE ; [ 12/06/2002 10:36 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5**;JUN 11, 2001
+2 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+3 ;IHS/DSD/CS;2991001;FIND ALL OF A TYPE OF TRANSITION AND RETRANSMIT
+4 ;
+5 ;Variables Used
+6 ; ZCS1=BATCH DATE (?)
+7 ; ZCS1S=START DATE
+8 ; ZCS1E=END DATE
+9 ; ZCS2=TYPE
+10 ; ZCS3=DOCUMENT IEN
+11 ; ZCS4=TRANSACTION IEN
+12 ;
BEGIN ;
+1 ;TEST FOR EXISTANCE OF DATA
+2 IF '$DATA(^ACHSF(DUZ(2),"TB"))
WRITE *7,!!,*7,"No data to process. Quiting."
QUIT
+3 SET (ZCS1,ZCS1S,ZCS1E,ZCS2,ZCS3,ZCS4,ZCS5)=""
+4 ;
+5 ;GET TRANSACTION TYPE
+6 KILL DIR
+7 SET DIR(0)="F^1:2^K:X'?.U X"
+8 SET DIR("A",1)="Select Transaction Type:"
+9 SET DIR("A",2)=" C Cancelation"
+10 SET DIR("A",3)=" I Initial"
+11 SET DIR("A",4)=" P Payment"
+12 SET DIR("A",5)=" IP Intrim Payment"
+13 SET DIR("A",6)=" ZA Adjustment"
+14 SET DIR("A")="Select C, I, P, IP, or ZA: "
+15 SET DIR("B")="C"
+16 DO ^DIR
+17 IF X=""
QUIT
+18 SET ZCS2=X
+19 ;
BDATE ;GET START DATE
+1 NEW DIR,Y
+2 WRITE !!
+3 SET DIR(0)="DO^::EX"
+4 SET DIR("A")="Enter Start Date: "
+5 DO ^DIR
+6 IF Y=""
WRITE *7," No date supplyed. Terminating."
QUIT
+7 IF Y>DT
WRITE *7," NO FUTURE DATES ALLOWED"
GOTO BDATE
+8 SET ZCS1S=Y
+9 ;
EDATE ;GET END DATE
+1 NEW DIR,Y
+2 WRITE !
+3 SET DIR(0)="DO^::EX"
+4 SET DIR("A")="Enter End Date: "
+5 SET DIR("B")=ZCS1S
+6 DO ^DIR
+7 IF Y=""
WRITE *7," No date supplyed. Returning to Start Date Entry."
GOTO BDATE
+8 IF Y>DT
WRITE *7," NO FUTURE DATES ALLOWED"
GOTO EDATE
+9 IF Y<ZCS1S
WRITE *7," Ending date must be after beginning date."
GOTO EDATE
+10 SET ZCS1E=Y
+11 ;
PROC ;ACTUAL PROCESSING STARTS HERE
+1 SET ZCS1=ZCS1S-1
+2 FOR
SET ZCS1=$ORDER(^ACHSF(DUZ(2),"TB",ZCS1))
IF ZCS1>ZCS1E!(ZCS1="")
QUIT
Begin DoDot:1
+3 IF '$DATA(^ACHSF(DUZ(2),"TB",ZCS1,ZCS2))
QUIT
+4 SET ZCS3=""
+5 FOR
SET ZCS3=$ORDER(^ACHSF(DUZ(2),"TB",ZCS1,ZCS2,ZCS3))
IF ZCS3=""
QUIT
Begin DoDot:2
+6 SET ZCS4=""
+7 FOR
SET ZCS4=$ORDER(^ACHSF(DUZ(2),"TB",ZCS1,ZCS2,ZCS3,ZCS4))
IF ZCS4=""
QUIT
Begin DoDot:3
+8 ;IF PROMPTING IS REQUIRED BEFORE CLEARING, IT GOES HERE.
+9 ; NOT FULL
IF ZCS2="C"
IF $PIECE(^ACHSF(DUZ(2),"D",ZCS3,"T",ZCS4,0),U,5)'="F"
QUIT
+10 SET ^TMP("ACHSTXAR",$JOB,ZCS1,ZCS3,ZCS4)=""
+11 SET ZCS5=1
End DoDot:3
End DoDot:2
End DoDot:1
+12 ; GO AND TRANSMIT THIS DATA NOW
+13 ; JUST BECAUSE WE WANT TO
SET ACHSIO=IO
+14 ; AREA CONTRACTING NUMBER
SET ACHSARCO=$PIECE(^ACHSF(DUZ(2),0),U,11)
+15 ;I +ACHSARCO<1!($L(ACHSARCO)'=3) D G EXIT ; CAN'T CONTINUE W/O THIS;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+16 ;. W !,"MISSING AREA CONTRACTING NUMBER - JOB ABBORTING";IHS/SET/GTH ACHS*3.1*5 12/06/2002
+17 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
IF '(ACHSARCO?3UN)
USE IO(0)
WRITE *7,!!,"Area Contracting Number is not 3 Upper-case Alpha-Numerics",!,"JOB CANCELLED"
GOTO EXIT
+18 ;
+19 ; INITIALIZE RECORD COUNTER
SET ACHSRCT=0
+20 ;
+21 ;pmf 6/6/1 add next line. init the re-export flag to NO.
+22 SET ACHSREEX=0
+23 IF ZCS5
DO ^ACHSTXA1
+24 ;
EXIT ; PUT CLEANUP STUFF HERE IF NEEDED
+1 QUIT
