ACHSPA.m

ACHSPA ; IHS/ITSC/PMF - DOCUMENT PAYMENT - DRIVER ;   [ 08/30/2004  2:28 PM ]

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**4,5,11**;JUN 11, 2001

 ;3.1*4  loop through payment prompts until the user is done

 ;3.1*11 8.30.04 IHS/ITSC/FCJ TEST FOR LOCK OF NODE

 ;

A1 ;

 K ACHSBLKF,^UTILITY($J)

 ;

 ;CHECK IF THE REGISTER IS CLOSED HASN'T THIS BEEN DONE BEFORE?????

 ;

 ;The purpose of so many checks on the register is that once the

 ;register is closed, there can be no more money recording for the

 ;day.  So each function that might change the amount of money

 ;owed or paid is blocked this way.

 ;

 I $D(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",+ACHSFYWK(DUZ(2),ACHSCFY),0)),$P(^(0),U,2)=DT W !!,*7,"  The Register Has Been CLOSED -- Document Payment is cancelled.",!,"Please advise your supervisor!" I $$DIR^XBDIR("E","Press RETURN...") D END Q

 ;

 ;ACHS*3.1*4   3/29/02  pmf  add a loop here so that we continue

 ;             prompting until they are done

 N STOP S STOP=0 F  D A2 Q:STOP  ;  ACHS*3.1*4

 Q  ;  ACHS*3.1*4

 ;

 ;

A2 ;

 D ^ACHSUSC   ;DISPLAY DOCUMENT CANCEL/SUPPLEMENTAL INFO

 ;

 I '$D(ACHSDIEN) D END Q

 I $D(DTOUT) D END Q

 I $D(DUOUT) K DUOUT Q

 ;

 I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")) W *7,!,"PAYMENT HAS ALREADY BEEN ENTERED.",!,"TRY ADJUSTMENT OPTION",!,"PAD    Payment Adjustment",!,"UNDER THE FACILITY MANAGEMENT MENU" G A2

        ;

 K ACHSBLKF,ACHSISAO

 ;

A3 ;EP - For automatic EOBR processing.

 K ACHSSET

 S ACHSX=+$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,14)     ;FISCAL YEAR

 D FYCVT^ACHSFU                                      ;COMPUTE ACTUAL

                                                     ;FISCAL YEAR

 S ACHSACFY=ACHSY,ACHSACWK=+ACHSFYWK(DUZ(2),ACHSACFY)

 ;

 D CKB^ACHSUUP                                ;CHECK DCR BALANCE

                                              ;VS. TOTAL OBLIGATED FYTD

 ;

 ;IF REGS BALANCE OUT AND IS AREA OFFICE ERROR=REGISTERS OUT OF BAL;E  

 I $D(ACHSCNC),$D(ACHSISAO) S ACHSERRE=13,ACHSEDAT="" D ^ACHSEOBG S ACHSERRA=1

 ;

 I $D(ACHSCNC) D END Q        ;REGISTERS OUT OF BALANCE

 ;

 D SBTRN^ACHSPA0              ;SET NEW TRANS NODE, GET MAX, PAYMENTS ETC

 I $D(DUOUT) D END Q  ;ACHS*3.1*11 8.30.04 IHS/ITSC/FCJ TEST FOR LOCK OF NODE

 ;

 D ^ACHSPAZ:'$D(ACHSISAO)     ;ENTER SVDT,WKLD,FULP,3RDP,VAMT

 ;

 I $D(DTOUT) D END Q

 ;

 ;ACHS*3.1*4   3/29/02  pmf  no more GOing to the top.

 ;I $D(DUOUT)!'$D(ACHSSET),'$D(ACHSISAO) LOCK  G A1  ;  ACHS*3.1*4

 ;I $D(DUOUT)!'$D(ACHSSET),'$D(ACHSISAO) L  Q  ;  ACHS*3.1*4

 I $D(DUOUT)!'$D(ACHSSET),'$D(ACHSISAO) LOCK  Q  ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 ;

 I '$D(ACHSBLKF) D A6 Q               ;BYPASS INTERACTIVE

 I $D(ACHSISAO) D A6 Q                ;BYPASS INTERACTIVE

 ;

 ;ACHS*3.1*4   3/29/02  pmf  no more GOing to the top.  one

 ;             line changed, one line removed

 ;I '$D(ACHSISAO) D A6 W !! G A1  ;  ACHS*3.1*4

 I '$D(ACHSISAO) D A6 Q  ;  ACHS*3.1*4

 ;G A1  ;  ACHS*3.1*4

 Q

 ;

A6 ;

 ;

 D ^ACHSPA0                                  ;DOCUMENT PAYMENT CONTINUED

 ;

 D ENTER^ACHSPAM:'$D(ACHSISAO)&'$D(ACHSBLKF) ;DOCUMENT PAYMENT

                                             ;ENTER/EDIT MEDICAL DATA

 LOCK             ;UNLOCK ALL LOCKS THAT WE MAY HAVE FORGOT

 ;

 ;IF 'PRINT SUPPLEMENT DOCUMENTS' GO Update the P.O. document status

 ;in the RCIS REFERRAL file

 I $$DOC^ACHS(2,7) S ACHSREF=$$DOC^ACHS(2,7) D AUTH^ACHSBMC K ACHSREF

 I '$D(ACHSISAO) Q      ;W !! G A1      ;IF NOT AREA OFFIC

 ;

END ;

 LOCK

 K ACHSADDT,ACHSCONP,ACHSCAN,ACHSDIDT,ACHSDITY,ACHSDRG,ACHSSCC,ACHSCOPT,ACHSESDA,ACHSESDO,ACHSFDT,ACHSTDT,ACHSHON,ACHSORDN,ACHSBLKF,ACHSIPA,ACHSPROV,ACHSSIG,ACHSSVDT,ACHSWKLD,ACHSFULP,ACHS3RDP,ACHS3RDS,ACHSUSE,X,X1,X2

 K ACHSADJ

 I '$D(ACHSISAO) K ACHSDERR,ACHSEOBR,ACHSTDA,^UTILITY($J)

 ;

 ;  ACHS*3.1*4   3/29/02  pmf  add STOP var

 I $D(STOP) S STOP=1  ;  ACHS*3.1*4

 ;

 Q

 ;

ACHSPA    ; IHS/ITSC/PMF - DOCUMENT PAYMENT - DRIVER ;   [ 08/30/2004  2:28 PM ]

 +1       ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**4,5,11**;JUN 11, 2001

 +2       ;3.1*4  loop through payment prompts until the user is done

 +3       ;3.1*11 8.30.04 IHS/ITSC/FCJ TEST FOR LOCK OF NODE

 +4       ;

A1        ;

 +1        KILL ACHSBLKF,^UTILITY($JOB)

 +2       ;

 +3       ;CHECK IF THE REGISTER IS CLOSED HASN'T THIS BEEN DONE BEFORE?????

 +4       ;

 +5       ;The purpose of so many checks on the register is that once the

 +6       ;register is closed, there can be no more money recording for the

 +7       ;day.  So each function that might change the amount of money

 +8       ;owed or paid is blocked this way.

 +9       ;

 +10       IF $DATA(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",+ACHSFYWK(DUZ(2),ACHSCFY),0))

               IF $PIECE(^(0),U,2)=DT

                   WRITE !!,*7,"  The Register Has Been CLOSED -- Document Payment is cancelled.",!,"Please advise your supervisor!"

                   IF $$DIR^XBDIR("E","Press RETURN...")

                       DO END

                       QUIT 

 +11      ;

 +12      ;ACHS*3.1*4   3/29/02  pmf  add a loop here so that we continue

 +13      ;             prompting until they are done

 +14      ;  ACHS*3.1*4

           NEW STOP

           SET STOP=0

           FOR 

               DO A2

               IF STOP

                   QUIT 

 +15      ;  ACHS*3.1*4

           QUIT 

 +16      ;

 +17      ;

A2        ;

 +1       ;DISPLAY DOCUMENT CANCEL/SUPPLEMENTAL INFO

           DO ^ACHSUSC

 +2       ;

 +3        IF '$DATA(ACHSDIEN)

               DO END

               QUIT 

 +4        IF $DATA(DTOUT)

               DO END

               QUIT 

 +5        IF $DATA(DUOUT)

               KILL DUOUT

               QUIT 

 +6       ;

 +7        IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"))

               WRITE *7,!,"PAYMENT HAS ALREADY BEEN ENTERED.",!,"TRY ADJUSTMENT OPTION",!,"PAD    Payment Adjustment",!,"UNDER THE FACILITY MANAGEMENT MENU"

               GOTO A2

 +8       ;

 +9        KILL ACHSBLKF,ACHSISAO

 +10      ;

A3        ;EP - For automatic EOBR processing.

 +1        KILL ACHSSET

 +2       ;FISCAL YEAR

           SET ACHSX=+$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,14)

 +3       ;COMPUTE ACTUAL

           DO FYCVT^ACHSFU

 +4       ;FISCAL YEAR

 +5        SET ACHSACFY=ACHSY

           SET ACHSACWK=+ACHSFYWK(DUZ(2),ACHSACFY)

 +6       ;

 +7       ;CHECK DCR BALANCE

           DO CKB^ACHSUUP

 +8       ;VS. TOTAL OBLIGATED FYTD

 +9       ;

 +10      ;IF REGS BALANCE OUT AND IS AREA OFFICE ERROR=REGISTERS OUT OF BAL;E  

 +11       IF $DATA(ACHSCNC)

               IF $DATA(ACHSISAO)

                   SET ACHSERRE=13

                   SET ACHSEDAT=""

                   DO ^ACHSEOBG

                   SET ACHSERRA=1

 +12      ;

 +13      ;REGISTERS OUT OF BALANCE

           IF $DATA(ACHSCNC)

               DO END

               QUIT 

 +14      ;

 +15      ;SET NEW TRANS NODE, GET MAX, PAYMENTS ETC

           DO SBTRN^ACHSPA0

 +16      ;ACHS*3.1*11 8.30.04 IHS/ITSC/FCJ TEST FOR LOCK OF NODE

           IF $DATA(DUOUT)

               DO END

               QUIT 

 +17      ;

 +18      ;ENTER SVDT,WKLD,FULP,3RDP,VAMT

           IF '$DATA(ACHSISAO)

               DO ^ACHSPAZ

 +19      ;

 +20       IF $DATA(DTOUT)

               DO END

               QUIT 

 +21      ;

 +22      ;ACHS*3.1*4   3/29/02  pmf  no more GOing to the top.

 +23      ;I $D(DUOUT)!'$D(ACHSSET),'$D(ACHSISAO) LOCK  G A1  ;  ACHS*3.1*4

 +24      ;I $D(DUOUT)!'$D(ACHSSET),'$D(ACHSISAO) L  Q  ;  ACHS*3.1*4

 +25      ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

           IF $DATA(DUOUT)!'$DATA(ACHSSET)

               IF '$DATA(ACHSISAO)

                   LOCK 

                   QUIT 

 +26      ;

 +27      ;BYPASS INTERACTIVE

           IF '$DATA(ACHSBLKF)

               DO A6

               QUIT 

 +28      ;BYPASS INTERACTIVE

           IF $DATA(ACHSISAO)

               DO A6

               QUIT 

 +29      ;

 +30      ;ACHS*3.1*4   3/29/02  pmf  no more GOing to the top.  one

 +31      ;             line changed, one line removed

 +32      ;I '$D(ACHSISAO) D A6 W !! G A1  ;  ACHS*3.1*4

 +33      ;  ACHS*3.1*4

           IF '$DATA(ACHSISAO)

               DO A6

               QUIT 

 +34      ;G A1  ;  ACHS*3.1*4

 +35       QUIT 

 +36      ;

A6        ;

 +1       ;

 +2       ;DOCUMENT PAYMENT CONTINUED

           DO ^ACHSPA0

 +3       ;

 +4       ;DOCUMENT PAYMENT

           IF '$DATA(ACHSISAO)&'$DATA(ACHSBLKF)

               DO ENTER^ACHSPAM

 +5       ;ENTER/EDIT MEDICAL DATA

 +6       ;UNLOCK ALL LOCKS THAT WE MAY HAVE FORGOT

           LOCK 

 +7       ;

 +8       ;IF 'PRINT SUPPLEMENT DOCUMENTS' GO Update the P.O. document status

 +9       ;in the RCIS REFERRAL file

 +10       IF $$DOC^ACHS(2,7)

               SET ACHSREF=$$DOC^ACHS(2,7)

               DO AUTH^ACHSBMC

               KILL ACHSREF

 +11      ;W !! G A1      ;IF NOT AREA OFFIC

           IF '$DATA(ACHSISAO)

               QUIT 

 +12      ;

END       ;

 +1        LOCK 

 +2        KILL ACHSADDT,ACHSCONP,ACHSCAN,ACHSDIDT,ACHSDITY,ACHSDRG,ACHSSCC,ACHSCOPT,ACHSESDA,ACHSESDO,ACHSFDT,ACHSTDT,ACHSHON,ACHSORDN,ACHSBLKF,ACHSIPA,ACHSPROV,ACHSSIG,ACHSSVDT,ACHSWKLD,ACHSFULP,ACHS3RDP,ACHS3RDS,ACHSUSE,X,X1,X2

 +3        KILL ACHSADJ

 +4        IF '$DATA(ACHSISAO)

               KILL ACHSDERR,ACHSEOBR,ACHSTDA,^UTILITY($JOB)

 +5       ;

 +6       ;  ACHS*3.1*4   3/29/02  pmf  add STOP var

 +7       ;  ACHS*3.1*4

           IF $DATA(STOP)

               SET STOP=1

 +8       ;

 +9        QUIT 

 +10      ;