ACHSCHF2 ; IHS/ITSC/TPF/PMF - C H E F UTILITY ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**15,16,18**;JUN 11, 2001
;ACHS*3.1*15 12.15.2008 IHS.OIT.FCJ ADDED FIELD TO ADD COMMENTS
;ACHS*3.1*16 11.05.2009 IHS.OIT.FCJ ADDED ADDITIONAL FIELD AND TEST FOR BLANKETS
;
Q
;
; --------------------------------------------------------------
;
AED ;EP - From option, Add/Edit/Delete CHEF case/P.O.'s.
N DIC,DIE,DA,DR
D SEL
Q:Y<1
S DA(1)=DUZ(2),DA=+Y
S DIE="^ACHSCHEF("_DUZ(2)_",1,"
;ACHS*3.1*15 12.15.2008 IHS/OIT/FCJ ADDED COMMENTS FIELD TO NXT LINE
;S DR=".01:.03;1"
;ACHS*3.1*16 11.05.2009 IHS/OIT/FCJ ADDED REIMBURSEMENT %, BLANKETS AND AMENDMENTS TO NXT LINE
;S DR=".01:.03;1;2"
;ACHS*3.1*18 7.21.2010 IHS/OIT/FCJ REMOVE .03 "TOTAL FUNDS RECIEVED" FR EDIT
;S DR=".01:.04;1;3;4;2"
S DR=".01;.02;.04;1;3;4;2"
D ^DIE
;ACHS*3.1*18 7.21.2010 IHS/OIT/FCJ ADDED NEXT 3 LINES
I $P(^ACHSCHEF(DUZ(2),1,DA,0),U,3)>0 D
.W !,"TOTAL FUNDS RECIEVED: ",$P(^ACHSCHEF(DUZ(2),1,DA,0),U,3)," Note: this is an amount that was entered prior"
.W !,"to the Amendment options and will be subtracted from total requested."
Q
;
; --------------------------------------------------------------
;
SEL ;EP -- Select a CHEF case.
N DIC,DA
I '$D(^ACHSCHEF(DUZ(2))) D FILE
S DIC="^ACHSCHEF("_DUZ(2)_",1,",DIC(0)="AELMQZ",DA(1)=DUZ(2)
D ^DIC
Q
;
; --------------------------------------------------------------
;
FILE ;
N DIC,DINUM
S DIC(0)="L",DIC="^ACHSCHEF(",(X,DINUM)=DUZ(2)
K DD,DO D FILE^DICN
S ^ACHSCHEF(DUZ(2),1,0)=$$ZEROTH^ACHS(9002064.1,1)
Q
;
; --------------------------------------------------------------
;
POIT ;EP - From dd, Input Transform for Purchase Order.
Q:'$D(X)
I $L(X)'=11 K X W:'$D(ZTQUEUED) " Must be 11 chars." Q
I '(X?1N1"-"1U2N1"-"5N) K X W:'$D(ZTQUEUED) " Not a P.O. number" Q
I $P(X,"-",2)'=$$FC^ACHS(DA(2)) K X W:'$D(ZTQUEUED) " Financial code must be ",$$FC^ACHS(DA(2)) Q
I '$D(^ACHSF(DA(2),"D","B",1_$E(X)_$P(X,"-",3))) K X W:'$D(ZTQUEUED) " P.O. does not exist" Q
N D
S D=$O(^ACHSF(DA(2),"D","B",1_$E(X)_$P(X,"-",3),0))
;ACHS*3.1*16 11/5/2009 IHS.OIT.FCJ ADDED ACHSB TST TO NEXT LINE THEN ADDED NEX LINE TO TEST FOR BLK/SL
;I $P($G(^ACHSF(DA(2),"D",D,0)),U,22)'=$P($G(^ACHSCHEF(DA(2),1,DA,0)),U,2) K X W:'$D(ZTQUEUED) " P.O. is not for Patient in this CHEF case" Q
I ACHSB=0,$P($G(^ACHSF(DA(2),"D",D,0)),U,22)'=$P($G(^ACHSCHEF(DA(2),1,DA,0)),U,2) K X W:'$D(ZTQUEUED) " P.O. is not for Patient in this CHEF case" K ACHSB Q
I ACHSB=1,$P($G(^ACHSF(DA(2),"D",D,0)),U,3)=0 K X W:'$D(ZTQUEUED) " P.O. is not a Blanket or Special Local type." K ACHSB Q
Q
;
; --------------------------------------------------------------
;
PARM ;EP - From option, Enter/Edit CHEF Parameters.
W !!
N ACHSFLD,DA,DIC,DIE,DR
S DA=DUZ(2),DIC=9002080
F ACHSFLD=14.27,14.31 W $J($P($G(^DD(DIC,ACHSFLD,0)),U),25)," = ",$$VAL^XBDIQ1(DIC,DA,ACHSFLD),!
S DIE="^ACHSF(",DR="14.27;14.31"
D ^DIE
Q
;
ACHSCHF2 ; IHS/ITSC/TPF/PMF - C H E F UTILITY ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**15,16,18**;JUN 11, 2001
+2 ;ACHS*3.1*15 12.15.2008 IHS.OIT.FCJ ADDED FIELD TO ADD COMMENTS
+3 ;ACHS*3.1*16 11.05.2009 IHS.OIT.FCJ ADDED ADDITIONAL FIELD AND TEST FOR BLANKETS
+4 ;
+5 QUIT
+6 ;
+7 ; --------------------------------------------------------------
+8 ;
AED ;EP - From option, Add/Edit/Delete CHEF case/P.O.'s.
+1 NEW DIC,DIE,DA,DR
+2 DO SEL
+3 IF Y<1
QUIT
+4 SET DA(1)=DUZ(2)
SET DA=+Y
+5 SET DIE="^ACHSCHEF("_DUZ(2)_",1,"
+6 ;ACHS*3.1*15 12.15.2008 IHS/OIT/FCJ ADDED COMMENTS FIELD TO NXT LINE
+7 ;S DR=".01:.03;1"
+8 ;ACHS*3.1*16 11.05.2009 IHS/OIT/FCJ ADDED REIMBURSEMENT %, BLANKETS AND AMENDMENTS TO NXT LINE
+9 ;S DR=".01:.03;1;2"
+10 ;ACHS*3.1*18 7.21.2010 IHS/OIT/FCJ REMOVE .03 "TOTAL FUNDS RECIEVED" FR EDIT
+11 ;S DR=".01:.04;1;3;4;2"
+12 SET DR=".01;.02;.04;1;3;4;2"
+13 DO ^DIE
+14 ;ACHS*3.1*18 7.21.2010 IHS/OIT/FCJ ADDED NEXT 3 LINES
+15 IF $PIECE(^ACHSCHEF(DUZ(2),1,DA,0),U,3)>0
Begin DoDot:1
+16 WRITE !,"TOTAL FUNDS RECIEVED: ",$PIECE(^ACHSCHEF(DUZ(2),1,DA,0),U,3)," Note: this is an amount that was entered prior"
+17 WRITE !,"to the Amendment options and will be subtracted from total requested."
End DoDot:1
+18 QUIT
+19 ;
+20 ; --------------------------------------------------------------
+21 ;
SEL ;EP -- Select a CHEF case.
+1 NEW DIC,DA
+2 IF '$DATA(^ACHSCHEF(DUZ(2)))
DO FILE
+3 SET DIC="^ACHSCHEF("_DUZ(2)_",1,"
SET DIC(0)="AELMQZ"
SET DA(1)=DUZ(2)
+4 DO ^DIC
+5 QUIT
+6 ;
+7 ; --------------------------------------------------------------
+8 ;
FILE ;
+1 NEW DIC,DINUM
+2 SET DIC(0)="L"
SET DIC="^ACHSCHEF("
SET (X,DINUM)=DUZ(2)
+3 KILL DD,DO
DO FILE^DICN
+4 SET ^ACHSCHEF(DUZ(2),1,0)=$$ZEROTH^ACHS(9002064.1,1)
+5 QUIT
+6 ;
+7 ; --------------------------------------------------------------
+8 ;
POIT ;EP - From dd, Input Transform for Purchase Order.
+1 IF '$DATA(X)
QUIT
+2 IF $LENGTH(X)'=11
KILL X
IF '$DATA(ZTQUEUED)
WRITE " Must be 11 chars."
QUIT
+3 IF '(X?1N1"-"1U2N1"-"5N)
KILL X
IF '$DATA(ZTQUEUED)
WRITE " Not a P.O. number"
QUIT
+4 IF $PIECE(X,"-",2)'=$$FC^ACHS(DA(2))
KILL X
IF '$DATA(ZTQUEUED)
WRITE " Financial code must be ",$$FC^ACHS(DA(2))
QUIT
+5 IF '$DATA(^ACHSF(DA(2),"D","B",1_$EXTRACT(X)_$PIECE(X,"-",3)))
KILL X
IF '$DATA(ZTQUEUED)
WRITE " P.O. does not exist"
QUIT
+6 NEW D
+7 SET D=$ORDER(^ACHSF(DA(2),"D","B",1_$EXTRACT(X)_$PIECE(X,"-",3),0))
+8 ;ACHS*3.1*16 11/5/2009 IHS.OIT.FCJ ADDED ACHSB TST TO NEXT LINE THEN ADDED NEX LINE TO TEST FOR BLK/SL
+9 ;I $P($G(^ACHSF(DA(2),"D",D,0)),U,22)'=$P($G(^ACHSCHEF(DA(2),1,DA,0)),U,2) K X W:'$D(ZTQUEUED) " P.O. is not for Patient in this CHEF case" Q
+10 IF ACHSB=0
IF $PIECE($GET(^ACHSF(DA(2),"D",D,0)),U,22)'=$PIECE($GET(^ACHSCHEF(DA(2),1,DA,0)),U,2)
KILL X
IF '$DATA(ZTQUEUED)
WRITE " P.O. is not for Patient in this CHEF case"
KILL ACHSB
QUIT
+11 IF ACHSB=1
IF $PIECE($GET(^ACHSF(DA(2),"D",D,0)),U,3)=0
KILL X
IF '$DATA(ZTQUEUED)
WRITE " P.O. is not a Blanket or Special Local type."
KILL ACHSB
QUIT
+12 QUIT
+13 ;
+14 ; --------------------------------------------------------------
+15 ;
PARM ;EP - From option, Enter/Edit CHEF Parameters.
+1 WRITE !!
+2 NEW ACHSFLD,DA,DIC,DIE,DR
+3 SET DA=DUZ(2)
SET DIC=9002080
+4 FOR ACHSFLD=14.27,14.31
WRITE $JUSTIFY($PIECE($GET(^DD(DIC,ACHSFLD,0)),U),25)," = ",$$VAL^XBDIQ1(DIC,DA,ACHSFLD),!
+5 SET DIE="^ACHSF("
SET DR="14.27;14.31"
+6 DO ^DIE
+7 QUIT
+8 ;
