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."
Q
;
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.",!
Q
;
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
Q
;
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
Q
S ; Supplemental
S ACHSOBLG=ACHSOBLG+$P(^ACHSF(L,"D",D,"T",T,0),U,4),$P(^ACHSF(L,"D",D,0),U,9)=ACHSOBLG
Q
C ; Cancellation
S ACHSOBLG=ACHSOBLG-$P(^ACHSF(L,"D",D,"T",T,0),U,4),$P(^ACHSF(L,"D",D,0),U,9)=ACHSOBLG
Q
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)
Q
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)
Q
IP ;
Q
;
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.
Q
;
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.
Q
;
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 ;
