ACHSRP3.m

ACHSRP3 ; IHS/ITSC/PMF - PRINT CHS (43 & 64) FORMS (1/2) ;   [ 10/16/2001   8:16 AM ]

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

 ;

 S T=0,E(8)=ACHSCOPT,ACHSSF="",LS=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U,6),ACHSLCA=$P(^(0),U,7),ACHSTYPE=$P(^(0),U,2)

 ;

 S:+LS>0 ACHSSF="S"_LS

 S:+ACHSLCA>0 ACHSSF="C"_ACHSLCA

 I ACHSTYPE="S" S E(11)=E(7),X=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U),E(7)=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3)

 ;D KILLNULS

TESTPRNT ;EP.  (For test print.)

PONUM ;

 W:'T !

 ;IF PARAM 'PRINT 3 DIGIT TYPE' IS YES

 ;

 W !?ACHSTAB+53,$S($$PARM^ACHS(2,20)="Y":$S(ACHSTYPV=1:323,ACHSTYPV=2:324,1:325),1:""),?ACHSTAB+60+$S(ACHSTYPV=1:2,1:0),"0",ACHSORDN,ACHSSF

DCR ;

 ;IF PARM 'PRINT DCR # ON P.O. 

 I $$PARM^ACHS(2,18)="Y" W " (",ACHSDCR,")"

ORDOFF ;

 W !!?ACHSTAB+42+T,B(1)

FACHRN ;

 W !

 W:$D(A(1)) ?ACHSTAB,A(1)

ORDADRS1 ;

 W:$D(B(2)) ?ACHSTAB+42+T,B(2)

NAME ;

 W !

 W:$D(A(2)) ?ACHSTAB,A(2)

SSV ;

 ;RETURN SSN VERIFICATION 

 I $G(DFN) S X=$$SSV^ACHSTX3(DFN) I "PVX"[X W ?ACHSTAB+28,X

ORDADRS2 ;

 W:$D(B(3)) ?ACHSTAB+42+T,B(3)

SUCODE ;

 W:$D(B(4)) ?69,"(",B(4),")"

PATADRS ;

 W !

 W:$D(A(3)) ?ACHSTAB,A(3)

AGESEX ;

 W !?ACHSTAB

 W:$D(A(4)) A(4),"    "

COMCODE ;

 W:$D(A(5)) A(5)

PROVIDER ;

 W:$D(D(1)) ?ACHSTAB+42+T,D(1)

PROADRS1 ;

 W !

 W:$D(D(2)) ?ACHSTAB+42+T,D(2)

 W !

DOS ;

 W:$D(A(6)) ?ACHSTAB,A(6)

PROADRS2 ;

 W:$D(D(3)) ?ACHSTAB+42+T,D(3)

FROMTO ;

 W !

 W:$D(C(4)) ?ACHSTAB,C(4)

PTYPE ;

 ;PRINT VENDOR TYPE?

 I $$PARM^ACHS(2,17)="Y",$D(D(7)) W ?ACHSTAB+39+T,D(7)

EIN ;

 W:$D(D(4)) ?ACHSTAB+42+T,D(4)

DESC ;

 W !

 W:$D(A(7)) ?ACHSTAB,A(7)

 S ACHSARCO=$P($G(^ACHSF(DUZ(2),0)),U,11)   ;AREA CONTRACTING NO.

 I F(6)'["Open Market",'$F("235^239^241^242^243^244^245^246^247^248^249^285",$E(F(6),1,3)) S F(6)=ACHSARCO_"-"_F(6)

 ;

CNTCANOB ;

 W !?ACHSTAB,"SCC: ",$G(F(8)) ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed. NEVER COMMENTED OUT

 S:T T=2

 F I=6,7,9 W ?ACHSTAB+$P("^^^^^42^58^^67",U,I)+T,$G(F(I)) I T S T=T-1

 W !!!?ACHSTAB,ACHSSIG

 S T=$S(ACHSTYPV=1:"32^41^62^70",1:"32^41^52^62")

DTOPTAMT ;

 F I=7:1:9 W:$D(E(I)) ?ACHSTAB+$P(T,U,I-6),E(I) I I=8,ACHSTYPV=1 W ?ACHSTAB+54,ACHSESDA

HSPORDNO ;

 W:$D(E(10)) ?ACHSTAB+$P(T,U,4),E(10)

 W !!!!!!!!!!!

 S I=$O(^ACHS(4,0))

 G CSUPL:ACHSDEST'="F",CSUPL:'I,CSUPL:'$D(^ACHS(4,I,0))

 W ?20,"PLEASE MAIL IHS-",$S(ACHSTYPV=1:"43",ACHSTYPV=3:"64",1:"")," AND COMPLETED HCFA-",$S(ACHSTYPV=1:"1450",ACHSTYPV=3:"1500",1:"")," TO:",!!?25,$P(^ACHS(4,I,0),U) W:$P(^(0),U,6)]"" !?25,$P(^(0),U,6)

 W !?25,$P(^ACHS(4,I,0),U,2),!?25,$P(^(0),U,3)

 W ", ",$P(^DIC(5,$P(^ACHS(4,I,0),U,4),0),U,2),"  ",$P(^ACHS(4,I,0),U,5)

CSUPL ;

 I ACHSTYPE="C"!(ACHSTYPE="S") D CSUPLA G END

 G END:$D(ACHSTPRT)!'$D(A(9))

 D ^ACHSRP31

END ;

 W @IOF

 Q

 ;

CSUPLA ;EP.

 S ACHSTYPE="********   "_$S(ACHSTYPE="C":"CANCELLATION   ********",1:"SUPPLEMENT TO P.O. DATED "_E(11))

 W !!

 F I=1:1:5 W ?25,ACHSTYPE,! I I=4,ACHSTYPE["CANCEL" S ACHSTYPE="CANCELLATION DATE "_$$FMTE^XLFDT($$TRAN^ACHS(0,1))

 Q

 ;

KILLNULS ;EP.

 F ACHSX="A","B","C","D","E","F" F ACHSY=1:1:12 S ACHS=ACHSX_"("_ACHSY_")" I $D(@ACHS),'$L(@ACHS) K @ACHS

 K ACHSX,ACHSY

 Q

 ;

ACHSRP3   ; IHS/ITSC/PMF - PRINT CHS (43 & 64) FORMS (1/2) ;   [ 10/16/2001   8:16 AM ]

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

 +2       ;

 +3        SET T=0

           SET E(8)=ACHSCOPT

           SET ACHSSF=""

           SET LS=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U,6)

           SET ACHSLCA=$PIECE(^(0),U,7)

           SET ACHSTYPE=$PIECE(^(0),U,2)

 +4       ;

 +5        IF +LS>0

               SET ACHSSF="S"_LS

 +6        IF +ACHSLCA>0

               SET ACHSSF="C"_ACHSLCA

 +7        IF ACHSTYPE="S"

               SET E(11)=E(7)

               SET X=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U)

               SET E(7)=$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)

 +8       ;D KILLNULS

TESTPRNT  ;EP.  (For test print.)

PONUM     ;

 +1        IF 'T

               WRITE !

 +2       ;IF PARAM 'PRINT 3 DIGIT TYPE' IS YES

 +3       ;

 +4        WRITE !?ACHSTAB+53,$SELECT($$PARM^ACHS(2,20)="Y":$SELECT(ACHSTYPV=1:323,ACHSTYPV=2:324,1:325),1:""),?ACHSTAB+60+$SELECT(ACHSTYPV=1:2,1:0),"0",ACHSORDN,ACHSSF

DCR       ;

 +1       ;IF PARM 'PRINT DCR # ON P.O. 

 +2        IF $$PARM^ACHS(2,18)="Y"

               WRITE " (",ACHSDCR,")"

ORDOFF    ;

 +1        WRITE !!?ACHSTAB+42+T,B(1)

FACHRN    ;

 +1        WRITE !

 +2        IF $DATA(A(1))

               WRITE ?ACHSTAB,A(1)

ORDADRS1  ;

 +1        IF $DATA(B(2))

               WRITE ?ACHSTAB+42+T,B(2)

NAME      ;

 +1        WRITE !

 +2        IF $DATA(A(2))

               WRITE ?ACHSTAB,A(2)

SSV       ;

 +1       ;RETURN SSN VERIFICATION 

 +2        IF $GET(DFN)

               SET X=$$SSV^ACHSTX3(DFN)

               IF "PVX"[X

                   WRITE ?ACHSTAB+28,X

ORDADRS2  ;

 +1        IF $DATA(B(3))

               WRITE ?ACHSTAB+42+T,B(3)

SUCODE    ;

 +1        IF $DATA(B(4))

               WRITE ?69,"(",B(4),")"

PATADRS   ;

 +1        WRITE !

 +2        IF $DATA(A(3))

               WRITE ?ACHSTAB,A(3)

AGESEX    ;

 +1        WRITE !?ACHSTAB

 +2        IF $DATA(A(4))

               WRITE A(4),"    "

COMCODE   ;

 +1        IF $DATA(A(5))

               WRITE A(5)

PROVIDER  ;

 +1        IF $DATA(D(1))

               WRITE ?ACHSTAB+42+T,D(1)

PROADRS1  ;

 +1        WRITE !

 +2        IF $DATA(D(2))

               WRITE ?ACHSTAB+42+T,D(2)

 +3        WRITE !

DOS       ;

 +1        IF $DATA(A(6))

               WRITE ?ACHSTAB,A(6)

PROADRS2  ;

 +1        IF $DATA(D(3))

               WRITE ?ACHSTAB+42+T,D(3)

FROMTO    ;

 +1        WRITE !

 +2        IF $DATA(C(4))

               WRITE ?ACHSTAB,C(4)

PTYPE     ;

 +1       ;PRINT VENDOR TYPE?

 +2        IF $$PARM^ACHS(2,17)="Y"

               IF $DATA(D(7))

                   WRITE ?ACHSTAB+39+T,D(7)

EIN       ;

 +1        IF $DATA(D(4))

               WRITE ?ACHSTAB+42+T,D(4)

DESC      ;

 +1        WRITE !

 +2        IF $DATA(A(7))

               WRITE ?ACHSTAB,A(7)

 +3       ;AREA CONTRACTING NO.

           SET ACHSARCO=$PIECE($GET(^ACHSF(DUZ(2),0)),U,11)

 +4        IF F(6)'["Open Market"

               IF '$FIND("235^239^241^242^243^244^245^246^247^248^249^285",$EXTRACT(F(6),1,3))

                   SET F(6)=ACHSARCO_"-"_F(6)

 +5       ;

CNTCANOB  ;

 +1       ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed. NEVER COMMENTED OUT

           WRITE !?ACHSTAB,"SCC: ",$GET(F(8))

 +2        IF T

               SET T=2

 +3        FOR I=6,7,9

               WRITE ?ACHSTAB+$PIECE("^^^^^42^58^^67",U,I)+T,$GET(F(I))

               IF T

                   SET T=T-1

 +4        WRITE !!!?ACHSTAB,ACHSSIG

 +5        SET T=$SELECT(ACHSTYPV=1:"32^41^62^70",1:"32^41^52^62")

DTOPTAMT  ;

 +1        FOR I=7:1:9

               IF $DATA(E(I))

                   WRITE ?ACHSTAB+$PIECE(T,U,I-6),E(I)

               IF I=8

                   IF ACHSTYPV=1

                       WRITE ?ACHSTAB+54,ACHSESDA

HSPORDNO  ;

 +1        IF $DATA(E(10))

               WRITE ?ACHSTAB+$PIECE(T,U,4),E(10)

 +2        WRITE !!!!!!!!!!!

 +3        SET I=$ORDER(^ACHS(4,0))

 +4        IF ACHSDEST'="F"

               GOTO CSUPL

           IF 'I

               GOTO CSUPL

           IF '$DATA(^ACHS(4,I,0))

               GOTO CSUPL

 +5        WRITE ?20,"PLEASE MAIL IHS-",$SELECT(ACHSTYPV=1:"43",ACHSTYPV=3:"64",1:"")," AND COMPLETED HCFA-",$SELECT(ACHSTYPV=1:"1450",ACHSTYPV=3:"1500",1:"")," TO:",!!?25,$PIECE(^ACHS(4,I,0),U)

           IF $PIECE(^(0),U,6)]""

               WRITE !?25,$PIECE(^(0),U,6)

 +6        WRITE !?25,$PIECE(^ACHS(4,I,0),U,2),!?25,$PIECE(^(0),U,3)

 +7        WRITE ", ",$PIECE(^DIC(5,$PIECE(^ACHS(4,I,0),U,4),0),U,2),"  ",$PIECE(^ACHS(4,I,0),U,5)

CSUPL     ;

 +1        IF ACHSTYPE="C"!(ACHSTYPE="S")

               DO CSUPLA

               GOTO END

 +2        IF $DATA(ACHSTPRT)!'$DATA(A(9))

               GOTO END

 +3        DO ^ACHSRP31

END       ;

 +1        WRITE @IOF

 +2        QUIT 

 +3       ;

CSUPLA    ;EP.

 +1        SET ACHSTYPE="********   "_$SELECT(ACHSTYPE="C":"CANCELLATION   ********",1:"SUPPLEMENT TO P.O. DATED "_E(11))

 +2        WRITE !!

 +3        FOR I=1:1:5

               WRITE ?25,ACHSTYPE,!

               IF I=4

                   IF ACHSTYPE["CANCEL"

                       SET ACHSTYPE="CANCELLATION DATE "_$$FMTE^XLFDT($$TRAN^ACHS(0,1))

 +4        QUIT 

 +5       ;

KILLNULS  ;EP.

 +1        FOR ACHSX="A","B","C","D","E","F"

               FOR ACHSY=1:1:12

                   SET ACHS=ACHSX_"("_ACHSY_")"

                   IF $DATA(@ACHS)

                       IF '$LENGTH(@ACHS)

                           KILL @ACHS

 +2        KILL ACHSX,ACHSY

 +3        QUIT 

 +4       ;