Routine: ACHSODP1

ACHSODP1 ; IHS/ITSC/PMF - PRINT DCR REPORT (2/3) ;  [ 10/16/2001   8:16 AM ]

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

 F I=1:1:9 S X=$P("D,N,R,ACHSPROV,DFN,T,O,A,ACHSDOS",",",I),@X=$P(ACHSACS,U,I)

 S (L(1),L(2))=""

 I DFN,$D(^DPT(DFN,0)) S X=$P(^(0),U),L(1)=$E(X,1,20) G A1

 S $P(L(1),U)=$S($P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,3)=1:"* BLANKET DOCUMENT *",$P(^(0),U,3)=2:"** SPEC LOC DOC **",1:"")

A1 ;

 I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,0)) S X=$P(^(0),U),L(2)=ACHSDPFX_$E(100000+X,2,6)

 I ACHSPROV,$D(^AUTTVNDR(ACHSPROV,0)) S X=^(0),$P(L(2),U,2)=$P(X,U,3),X=$P(X,U),$P(L(1),U,2)=$E(X,1,25)

 S $P(L(1),U,3)=$E(100+$E(D,4,5),2,3)_$E(100+$E(D,6,7),2,3)_$E(D,2,3)

 I ACHSDOS S $P(L(1),U,3)=$P(L(1),U,3)_"/"_$E(100+$E(ACHSDOS,4,5),2,3)_$E(100+$E(ACHSDOS,6,7),2,3)

 S X=$$DOC^ACHS(0,4),$P(L(2),U,3)=$S(X=1:"HOSPITAL",X=2:"DENTAL",X=3:"OUTPAT",1:"")

 S X=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,17),$P(L(2),U,4)=$S(X="I":"IHS",1:"FI") I T="IP" S $P(L(2),U,4)=$P(L(2),U,4)_"  NOT IN TOTALS"

 S $P(L(2),U,2)=$P(^AUTTVNDR(ACHSPROV,11),U)

 I T="P" S D=$S(O>0:1,O<0:2,1:0) S X="P "_$P(">^<",U,D)_" Obl"

 E  S X=$P($T(@T),";;",2,99),D=$S(T="I":1,T="S":1,T="C":2,T="D":2,1:0)

 S $P(L(1),U,4)=X

 I T="ZA" S D=$S(O<0:2,1:1),$P(L(1),U,5)=$J(O,1,2) G A2

 I T="IP" S $P(L(1),U,5)=$J(O,1,2) ;G A3

 I T'="P" S:D=1 $P(L(1),U,5)=$J(O,1,2) S:D=2 $P(L(1),U,5)=$J(O*-1,1,2) G A2

 I O=0 S $P(L(1),U,4)="P = Obl"

 E  S $P(L(1),U,5)=$J(O,1,2)

A2 ;

 I D S:O<0 O=O*-1 S $P(ACHSSUM(R),U,D)=$P(ACHSSUM(R),U,D)+O

A3 ;

 F J=1,2 W ! F I=1:1:5 W ?$P("0^22^49^62^69",U,I) W:I<5 $P(L(J),U,I) I I=5 S X=$P(L(J),U,5) W ?80-$L(X),X

W !

 K ACHSPROV

I ;;INIT

C ;;C-CANC

D ;;P-CANC

S ;;SUPPL

M ;;P-MEMO

P ;;PAYMENT

IP ;;INT-PMT

ZA ;;ADJUST

ACHSODP1  ; IHS/ITSC/PMF - PRINT DCR REPORT (2/3) ;  [ 10/16/2001   8:16 AM ]

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

 +2       ;

 +3        FOR I=1:1:9

               SET X=$PIECE("D,N,R,ACHSPROV,DFN,T,O,A,ACHSDOS",",",I)

               SET @X=$PIECE(ACHSACS,U,I)

 +4        SET (L(1),L(2))=""

 +5        IF DFN

               IF $DATA(^DPT(DFN,0))

                   SET X=$PIECE(^(0),U)

                   SET L(1)=$EXTRACT(X,1,20)

                   GOTO A1

 +6       ;

 +7        SET $PIECE(L(1),U)=$SELECT($PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,3)=1:"* BLANKET DOCUMENT *",$PIECE(^(0),U,3)=2:"** SPEC LOC DOC **",1:"")

A1        ;

 +1        IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,0))

               SET X=$PIECE(^(0),U)

               SET L(2)=ACHSDPFX_$EXTRACT(100000+X,2,6)

 +2       ;

 +3        IF ACHSPROV

               IF $DATA(^AUTTVNDR(ACHSPROV,0))

                   SET X=^(0)

                   SET $PIECE(L(2),U,2)=$PIECE(X,U,3)

                   SET X=$PIECE(X,U)

                   SET $PIECE(L(1),U,2)=$EXTRACT(X,1,25)

 +4       ;

 +5        SET $PIECE(L(1),U,3)=$EXTRACT(100+$EXTRACT(D,4,5),2,3)_$EXTRACT(100+$EXTRACT(D,6,7),2,3)_$EXTRACT(D,2,3)

 +6       ;

 +7        IF ACHSDOS

               SET $PIECE(L(1),U,3)=$PIECE(L(1),U,3)_"/"_$EXTRACT(100+$EXTRACT(ACHSDOS,4,5),2,3)_$EXTRACT(100+$EXTRACT(ACHSDOS,6,7),2,3)

 +8        SET X=$$DOC^ACHS(0,4)

           SET $PIECE(L(2),U,3)=$SELECT(X=1:"HOSPITAL",X=2:"DENTAL",X=3:"OUTPAT",1:"")

 +9        SET X=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,17)

           SET $PIECE(L(2),U,4)=$SELECT(X="I":"IHS",1:"FI")

           IF T="IP"

               SET $PIECE(L(2),U,4)=$PIECE(L(2),U,4)_"  NOT IN TOTALS"

 +10       SET $PIECE(L(2),U,2)=$PIECE(^AUTTVNDR(ACHSPROV,11),U)

 +11       IF T="P"

               SET D=$SELECT(O>0:1,O<0:2,1:0)

               SET X="P "_$PIECE(">^<",U,D)_" Obl"

 +12      IF '$TEST

               SET X=$PIECE($TEXT(@T),";;",2,99)

               SET D=$SELECT(T="I":1,T="S":1,T="C":2,T="D":2,1:0)

 +13       SET $PIECE(L(1),U,4)=X

 +14       IF T="ZA"

               SET D=$SELECT(O<0:2,1:1)

               SET $PIECE(L(1),U,5)=$JUSTIFY(O,1,2)

               GOTO A2

 +15      ;G A3

           IF T="IP"

               SET $PIECE(L(1),U,5)=$JUSTIFY(O,1,2)

 +16       IF T'="P"

               IF D=1

                   SET $PIECE(L(1),U,5)=$JUSTIFY(O,1,2)

               IF D=2

                   SET $PIECE(L(1),U,5)=$JUSTIFY(O*-1,1,2)

               GOTO A2

 +17       IF O=0

               SET $PIECE(L(1),U,4)="P = Obl"

 +18      IF '$TEST

               SET $PIECE(L(1),U,5)=$JUSTIFY(O,1,2)

A2        ;

 +1        IF D

               IF O<0

                   SET O=O*-1

               SET $PIECE(ACHSSUM(R),U,D)=$PIECE(ACHSSUM(R),U,D)+O

A3        ;

 +1        FOR J=1,2

               WRITE !

               FOR I=1:1:5

                   WRITE ?$PIECE("0^22^49^62^69",U,I)

                   IF I<5

                       WRITE $PIECE(L(J),U,I)

                   IF I=5

                       SET X=$PIECE(L(J),U,5)

                       WRITE ?80-$LENGTH(X),X

 +2        WRITE !

 +3        KILL ACHSPROV

 +4        QUIT

 +5       ;

I         ;;INIT

C         ;;C-CANC

D         ;;P-CANC

S         ;;SUPPL

M         ;;P-MEMO

P         ;;PAYMENT

IP        ;;INT-PMT

ZA        ;;ADJUST

ACHSODP1.m