ACHSYCS.m

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