ACHSCHF2.m

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       ;