Routine: ACHSYAMT

ACHSYAMT ; IHS/ITSC/PMF - RECALC OBLIGATION AMOUNTS ;  [ 10/16/2001   8:16 AM ]

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001

 ; This routine ensures the obligated amount is correct for each

 ; document.  It is uncertain whether it needs to be run for each

 ; facility that installs CHS, as the incorrect obligated amount

 ; was incurred at a very few sites that participated in the Alpha

 ; test during development of 2.0.

 ; This was part of the postinit for version 2.0.

 I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." Q

 D HOME^%ZIS,DT^DICRW,INTRO

 S (DIR(0),DIR("B"))="Y"

 S DIR("A")="Do you want to queue the updates to TaskMan"

 S DIR("??")="^D Q2^ACHSYAMT"

 D ^DIR

 G Q2:$D(DIRUT),START:'Y

QUE ;

 S %DT="AERSX",%DT("A")="Requested Start Time: ",%DT("B")="T@2015",%DT(0)="NOW"

 D ^%DT

 I Y<1 W !,"QUEUE INFORMATION MISSING - NOT QUEUED",!!,"Okay.",! D Q2 Q

 S X=+Y

 D H^%DTC

 S ZTDTH=%H_","_%T

 S ZTRTN="START^ACHSYAMT",ZTIO="",ZTDESC=$P($P($T(+1),";",2)," ",4,99)

 D ^%ZTLOAD,HOME^%ZIS

 I $D(ZTSK) W !!,"QUEUED TO TASK ",ZTSK,!!,"A mail message with the results will be sent to your MailMan 'IN' basket.",! K ^TMP("ACHSYAMT",$J)

 E  W !!,*7,"QUEUE UNSUCCESSFUL.  RESTART UTILITY."

START ;EP - From Taskman

 N XMSUB,XMDUZ,XMTEXT,XMY

 K ^TMP("ACHSYAMT",$J)

 D WORK

 S (XMSUB,XMDUZ)=$P($P($T(+1),";",2)," ",4,99),XMTEXT="^TMP(""ACHSYAMT"",$J,""RSLT"",",XMY(1)="",XMY(DUZ)="" D ^XMD

 K ^TMP("ACHSYAMT",$J)

 I $D(ZTQUEUED) S ZTREQ="@"

 E  W !!,"The results are in your MailMan 'IN' basket.",!

WORK ;

 D RSLT("*** RESETTING 3RD PARTY PAY, OBLICATIONS AND PAYMENT NODES IN DOCUMENT FILE ***")

 ; L = Location (DUZ(2)), C = Counter

 S (C,L)=0

LOC ;

 S L=$O(^ACHSF(L))

 G END:'L

 D RSLT("Processing "_$P(^DIC(4,L,0),U)_" PO's.")

 S D=0

DOC ;

 S D=$O(^ACHSF(L,"D",D))

 G LOC:'D

 LOCK +^ACHSF(L,"D",D):30

 E  D RSLT("Can't LOCK ^ACHSF("_L_"""D"","_D_").") G DOC

 S ACHSOBLG=0,C=C+1

 I '$D(ZTQUEUED),'(C#100) W "."

 S T=0

TRANS ;

 S T=$O(^ACHSF(L,"D",D,"T",T))

 I 'T LOCK -^ACHSF(L,"D",D) G DOC

 S %=$P(^ACHSF(L,"D",D,"T",T,0),U,2)

 D @%

 G TRANS

END ;

 D RSLT(C_" PO's processed.")

 D RSLT("CHS data updates complete.")

 K ACHSAMT,D,T,ACHSOBLG,C

RSLT(%) S ^(0)=$G(^TMP("ACHSYAMT",$J,"RSLT",0))+1,^(^(0))=% W:'$D(ZTQUEUED) !,% Q

I ; Initial

 S ACHSOBLG=ACHSOBLG+$P(^ACHSF(L,"D",D,"T",T,0),U,4),$P(^ACHSF(L,"D",D,0),U,9)=ACHSOBLG

S ; Supplemental

 S ACHSOBLG=ACHSOBLG+$P(^ACHSF(L,"D",D,"T",T,0),U,4),$P(^ACHSF(L,"D",D,0),U,9)=ACHSOBLG

C ; Cancellation

 S ACHSOBLG=ACHSOBLG-$P(^ACHSF(L,"D",D,"T",T,0),U,4),$P(^ACHSF(L,"D",D,0),U,9)=ACHSOBLG

P ; Payment

 S ACHSAMT=$P(^ACHSF(L,"D",D,"T",T,0),U,8)

 S $P(^ACHSF(L,"D",D,"PA"),U,5)=ACHSAMT

 Q:'$D(^ACHSF(L,"D",D,"PA"))

 Q:$P(^ACHSF(L,"D",D,"PA"),U,6)

 S $P(^ACHSF(L,"D",D,"PA"),U,6)=$P(^("PA"),U,1)

 S:$D(^ACHSF(L,"D",D,"IP")) $P(^("PA"),U,1)=$P(^("PA"),U,1)+$P(^("IP"),U,1)

 S $P(^ACHSF(L,"D",D,"PA"),U,2)=$P(^("PA"),U,1)-$P(^ACHSF(L,"D",D,0),U,9)

ZA ; Adjustment

 S ACHSAMT=$P(^ACHSF(L,"D",D,"T",T,0),U,8)

 S $P(^ACHSF(L,"D",D,"ZA"),U,4)=ACHSAMT

 S $P(^ACHSF(L,"D",D,"ZA"),U,1)=$P(^("ZA"),U,2)+$P(^ACHSF(L,"D",D,"PA"),U,1)

IP ;

INTRO ;

 W ! F %=2:1:4 W ?5,$P($T(INTRO+%),";;",2),!

 ;;This utility reads thru each PO, re-adds the total amount obligated

 ;;for each document, and ensures the total amount obligated field

 ;;in the Document record is correct.

Q2 ;EP - From DIR

 W ! F %=2:1:6 W ?5,$P($T(Q2+%),";;",2),!

 ;;Answer "Y" or "N" to q to TaskMan or not.

;;

 ;;If you run interactively, results will be displayed on your screen,

 ;;as well as in the mail message sent to you and user 1.  If you queue

 ;;to TaskMan, please read the mail message for results of this patch.

ACHSYAMT  ; IHS/ITSC/PMF - RECALC OBLIGATION AMOUNTS ;  [ 10/16/2001   8:16 AM ]

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

 +2       ;

 +3       ; This routine ensures the obligated amount is correct for each

 +4       ; document.  It is uncertain whether it needs to be run for each

 +5       ; facility that installs CHS, as the incorrect obligated amount

 +6       ; was incurred at a very few sites that participated in the Alpha

 +7       ; test during development of 2.0.

 +8       ;

 +9       ; This was part of the postinit for version 2.0.

 +10      ;

 +11       IF '$GET(DUZ)

               WRITE !,"DUZ UNDEFINED OR 0."

               QUIT

 +12       DO HOME^%ZIS

           DO DT^DICRW

           DO INTRO

 +13       SET (DIR(0),DIR("B"))="Y"

 +14       SET DIR("A")="Do you want to queue the updates to TaskMan"

 +15       SET DIR("??")="^D Q2^ACHSYAMT"

 +16       DO ^DIR

 +17       IF $DATA(DIRUT)

               GOTO Q2

           IF 'Y

               GOTO START

QUE       ;

 +1        SET %DT="AERSX"

           SET %DT("A")="Requested Start Time: "

           SET %DT("B")="T@2015"

           SET %DT(0)="NOW"

 +2        DO ^%DT

 +3        IF Y<1

               WRITE !,"QUEUE INFORMATION MISSING - NOT QUEUED",!!,"Okay.",!

               DO Q2

               QUIT

 +4        SET X=+Y

 +5        DO H^%DTC

 +6        SET ZTDTH=%H_","_%T

 +7        SET ZTRTN="START^ACHSYAMT"

           SET ZTIO=""

           SET ZTDESC=$PIECE($PIECE($TEXT(+1),";",2)," ",4,99)

 +8        DO ^%ZTLOAD

           DO HOME^%ZIS

 +9        IF $DATA(ZTSK)

               WRITE !!,"QUEUED TO TASK ",ZTSK,!!,"A mail message with the results will be sent to your MailMan 'IN' basket.",!

               KILL ^TMP("ACHSYAMT",$JOB)

 +10      IF '$TEST

               WRITE !!,*7,"QUEUE UNSUCCESSFUL.  RESTART UTILITY."

 +11       QUIT

 +12      ;

START     ;EP - From Taskman

 +1       ;

 +2        NEW XMSUB,XMDUZ,XMTEXT,XMY

 +3        KILL ^TMP("ACHSYAMT",$JOB)

 +4        DO WORK

 +5        SET (XMSUB,XMDUZ)=$PIECE($PIECE($TEXT(+1),";",2)," ",4,99)

           SET XMTEXT="^TMP(""ACHSYAMT"",$J,""RSLT"","

           SET XMY(1)=""

           SET XMY(DUZ)=""

           DO ^XMD

 +6        KILL ^TMP("ACHSYAMT",$JOB)

 +7        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +8       IF '$TEST

               WRITE !!,"The results are in your MailMan 'IN' basket.",!

 +9        QUIT

 +10      ;

WORK      ;

 +1        DO RSLT("*** RESETTING 3RD PARTY PAY, OBLICATIONS AND PAYMENT NODES IN DOCUMENT FILE ***")

 +2       ;

 +3       ; L = Location (DUZ(2)), C = Counter

 +4        SET (C,L)=0

LOC       ;

 +1        SET L=$ORDER(^ACHSF(L))

 +2        IF 'L

               GOTO END

 +3        DO RSLT("Processing "_$PIECE(^DIC(4,L,0),U)_" PO's.")

 +4        SET D=0

DOC       ;

 +1        SET D=$ORDER(^ACHSF(L,"D",D))

 +2        IF 'D

               GOTO LOC

 +3        LOCK +^ACHSF(L,"D",D):30

 +4       IF '$TEST

               DO RSLT("Can't LOCK ^ACHSF("_L_"""D"","_D_").")

               GOTO DOC

 +5        SET ACHSOBLG=0

           SET C=C+1

 +6        IF '$DATA(ZTQUEUED)

               IF '(C#100)

                   WRITE "."

 +7        SET T=0

TRANS     ;

 +1        SET T=$ORDER(^ACHSF(L,"D",D,"T",T))

 +2        IF 'T

               LOCK -^ACHSF(L,"D",D)

               GOTO DOC

 +3        SET %=$PIECE(^ACHSF(L,"D",D,"T",T,0),U,2)

 +4        DO @%

 +5        GOTO TRANS

END       ;

 +1        DO RSLT(C_" PO's processed.")

 +2        DO RSLT("CHS data updates complete.")

 +3        KILL ACHSAMT,D,T,ACHSOBLG,C

 +4        QUIT

 +5       ;

RSLT(%)    SET ^(0)=$GET(^TMP("ACHSYAMT",$JOB,"RSLT",0))+1

           SET ^(^(0))=%

           IF '$DATA(ZTQUEUED)

               WRITE !,%

           QUIT

 +1       ;

I         ; Initial

 +1        SET ACHSOBLG=ACHSOBLG+$PIECE(^ACHSF(L,"D",D,"T",T,0),U,4)

           SET $PIECE(^ACHSF(L,"D",D,0),U,9)=ACHSOBLG

 +2        QUIT

S         ; Supplemental

 +1        SET ACHSOBLG=ACHSOBLG+$PIECE(^ACHSF(L,"D",D,"T",T,0),U,4)

           SET $PIECE(^ACHSF(L,"D",D,0),U,9)=ACHSOBLG

 +2        QUIT

C         ; Cancellation

 +1        SET ACHSOBLG=ACHSOBLG-$PIECE(^ACHSF(L,"D",D,"T",T,0),U,4)

           SET $PIECE(^ACHSF(L,"D",D,0),U,9)=ACHSOBLG

 +2        QUIT

P         ; Payment

 +1        SET ACHSAMT=$PIECE(^ACHSF(L,"D",D,"T",T,0),U,8)

 +2        SET $PIECE(^ACHSF(L,"D",D,"PA"),U,5)=ACHSAMT

 +3        IF '$DATA(^ACHSF(L,"D",D,"PA"))

               QUIT

 +4        IF $PIECE(^ACHSF(L,"D",D,"PA"),U,6)

               QUIT

 +5        SET $PIECE(^ACHSF(L,"D",D,"PA"),U,6)=$PIECE(^("PA"),U,1)

 +6        IF $DATA(^ACHSF(L,"D",D,"IP"))

               SET $PIECE(^("PA"),U,1)=$PIECE(^("PA"),U,1)+$PIECE(^("IP"),U,1)

 +7        SET $PIECE(^ACHSF(L,"D",D,"PA"),U,2)=$PIECE(^("PA"),U,1)-$PIECE(^ACHSF(L,"D",D,0),U,9)

 +8        QUIT

ZA        ; Adjustment

 +1        SET ACHSAMT=$PIECE(^ACHSF(L,"D",D,"T",T,0),U,8)

 +2        SET $PIECE(^ACHSF(L,"D",D,"ZA"),U,4)=ACHSAMT

 +3        SET $PIECE(^ACHSF(L,"D",D,"ZA"),U,1)=$PIECE(^("ZA"),U,2)+$PIECE(^ACHSF(L,"D",D,"PA"),U,1)

 +4        QUIT

IP        ;

 +1        QUIT

 +2       ;

INTRO     ;

 +1        WRITE !

           FOR %=2:1:4

               WRITE ?5,$PIECE($TEXT(INTRO+%),";;",2),!

 +2       ;;This utility reads thru each PO, re-adds the total amount obligated

 +3       ;;for each document, and ensures the total amount obligated field

 +4       ;;in the Document record is correct.

 +5        QUIT

 +6       ;

Q2        ;EP - From DIR

 +1        WRITE !

           FOR %=2:1:6

               WRITE ?5,$PIECE($TEXT(Q2+%),";;",2),!

 +2       ;;Answer "Y" or "N" to q to TaskMan or not.

 +3       ;;

 +4       ;;If you run interactively, results will be displayed on your screen,

 +5       ;;as well as in the mail message sent to you and user 1.  If you queue

 +6       ;;to TaskMan, please read the mail message for results of this patch.

 +7        QUIT

 +8       ;

ACHSYAMT.m