ACHSTX6 ; IHS/ITSC/PMF - EXPORT DATA (7/9) - RECORD 6(PAY FOR AO) ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
I $$PARM^ACHS(2,12)'="Y" G END
W !!?10,"BUILDING ",$$REC^ACHSACO1(6)," : ",!?9
S R=0
A1 ;
S R=$O(^ACHSTXPD(R))
G END:'R
S ACHSDOCR=$G(^ACHSF(DUZ(2),"D",R,0)),ACHSRR=0
A2 ;
S ACHSRR=$O(^ACHSTXPD(R,ACHSRR))
G A1:'ACHSRR
S ACHSTRAN=$G(^ACHSF(DUZ(2),"D",R,"T",ACHSRR,0))
I $P(ACHSTRAN,U,2)'="P" G A2
S ACHSDOCN=$P(ACHSDOCR,U,14)_ACHSFC_$E($P(ACHSDOCR,U)+100000,2,6)
D TOS^ACHSTX8
S ACHSFAC=ACHSAFAC,(X,X1)=$P(ACHSDOCR,U,8),ACHSEIN=$P($G(^AUTTVNDR(X,11)),U)_$P($G(^(11)),U,2),ACHSEIN=$E(ACHSEIN_$J("",12),1,12),ACHSFED=$S($P($G(^AUTTVNDR(X1,11)),U,10)=2:2,1:1)
S ACHSPTYP=" ",X=$P($G(^AUTTVNDR($P(ACHSDOCR,U,8),11)),U,3)
I +X,$D(^AUTTVTYP(X,0)) S ACHSPTYP=$P(^(0),U)
S ACHSHRN=$P(ACHSDOCR,U,21)
I ACHSHRN<1,$P(ACHSTRAN,U,3) S ACHSHRN=$$HRN^ACHS($P(ACHSTRAN,U,3),DUZ(2))
S ACHSHRN=$E(ACHSHRN+1000000,2,7),ACHSCN=$E($P(ACHSDOCR,U,5)_$J("",10),1,10)
D CANOBJ^ACHSTX8
S ACHSDCR=$E($P(ACHSDOCR,U,19)+100,2,3),ACHSRCT=ACHSRCT+1,ACHSRTYP(6)=ACHSRTYP(6)+1
S ^ACHSDATA(ACHSRCT)="6A"_ACHSDOCN_ACHSTOS2_$P(ACHSDOCR,U,2)_"6"_ACHSFAC_ACHSHRN_ACHSEIN_ACHSPTYP_ACHSFED_ACHSCN_ACHSCAN_ACHSOBJC_ACHSDCR_$J("",10)
;
S X=$P(ACHSDOCR,U,9),X=$P(X,".",1)_$E($P(X,".",2)_"00",1,2),ACHSOAMT=$E(X+100000000,2,9)
D IPA^ACHSTX8
S ACHSIPA=$E(ACHSIPA,5,12),ACHSFULP=$S($P(ACHSTRAN,U,5)="P":2,1:1),X=$P(ACHSTRAN,U,3)
G A3:+X<1,A4:$D(^DPT(X))
A3 ;
S ACHSLNAM=$J("",20),ACHSFNAM=$J("",10)
G A5
;
A4 ;
S ACHSLNAM=$E($P($P($G(^DPT(X,0)),U),",")_$J("",20),1,20),ACHSFNAM=$E($P($P($G(^DPT(X,0)),U),",",2)_$J("",10),1,10)
A5 ;
S ACHSWKLD=$E(+$P(ACHSTRAN,U,9)+1000,2,4),ACHSDOS=$P(ACHSTRAN,U,10) S:ACHSDOS="" ACHSDOS=" "
S X=$P(ACHSTRAN,U,8),X=$P(X,".",1)_$E($P(X,".",2)_"00",1,2),ACHSTHRD=$E(X+100000000,2,9)
S ACHSRCT=ACHSRCT+1
S ^ACHSDATA(ACHSRCT)="6B"_ACHSOAMT_ACHSIPA_ACHSFULP_ACHSLNAM_ACHSFNAM_ACHSDOS_ACHSWKLD_ACHSTHRD_$J("",14)
;
S ACHSRTYP(6)=ACHSRTYP(6)+1
I ACHSRTYP(6)#10=0 W $J(ACHSRTYP(6),8)
G A2
;
END ;
K ACHSCN,ACHSDCR,ACHSDOCN,ACHSDOS,ACHSFNAM,ACHSFULP,ACHSHRN,ACHSIPA,ACHSLNAM,ACHSOAMT,ACHSSCC,ACHSTRAN,ACHSWKLD,ACHSTOS,ACHSPTYP
S ACHSROUT=ACHSRCT
G ^ACHSTX7
;
ACHSTX6 ; IHS/ITSC/PMF - EXPORT DATA (7/9) - RECORD 6(PAY FOR AO) ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
+3 IF $$PARM^ACHS(2,12)'="Y"
GOTO END
+4 WRITE !!?10,"BUILDING ",$$REC^ACHSACO1(6)," : ",!?9
+5 SET R=0
A1 ;
+1 SET R=$ORDER(^ACHSTXPD(R))
+2 IF 'R
GOTO END
+3 SET ACHSDOCR=$GET(^ACHSF(DUZ(2),"D",R,0))
SET ACHSRR=0
A2 ;
+1 SET ACHSRR=$ORDER(^ACHSTXPD(R,ACHSRR))
+2 IF 'ACHSRR
GOTO A1
+3 SET ACHSTRAN=$GET(^ACHSF(DUZ(2),"D",R,"T",ACHSRR,0))
+4 IF $PIECE(ACHSTRAN,U,2)'="P"
GOTO A2
+5 SET ACHSDOCN=$PIECE(ACHSDOCR,U,14)_ACHSFC_$EXTRACT($PIECE(ACHSDOCR,U)+100000,2,6)
+6 DO TOS^ACHSTX8
+7 SET ACHSFAC=ACHSAFAC
SET (X,X1)=$PIECE(ACHSDOCR,U,8)
SET ACHSEIN=$PIECE($GET(^AUTTVNDR(X,11)),U)_$PIECE($GET(^(11)),U,2)
SET ACHSEIN=$EXTRACT(ACHSEIN_$JUSTIFY("",12),1,12)
SET ACHSFED=$SELECT($PIECE($GET(^AUTTVNDR(X1,11)),U,10)=2:2,1:1)
+8 SET ACHSPTYP=" "
SET X=$PIECE($GET(^AUTTVNDR($PIECE(ACHSDOCR,U,8),11)),U,3)
+9 IF +X
IF $DATA(^AUTTVTYP(X,0))
SET ACHSPTYP=$PIECE(^(0),U)
+10 SET ACHSHRN=$PIECE(ACHSDOCR,U,21)
+11 IF ACHSHRN<1
IF $PIECE(ACHSTRAN,U,3)
SET ACHSHRN=$$HRN^ACHS($PIECE(ACHSTRAN,U,3),DUZ(2))
+12 SET ACHSHRN=$EXTRACT(ACHSHRN+1000000,2,7)
SET ACHSCN=$EXTRACT($PIECE(ACHSDOCR,U,5)_$JUSTIFY("",10),1,10)
+13 DO CANOBJ^ACHSTX8
+14 SET ACHSDCR=$EXTRACT($PIECE(ACHSDOCR,U,19)+100,2,3)
SET ACHSRCT=ACHSRCT+1
SET ACHSRTYP(6)=ACHSRTYP(6)+1
+15 SET ^ACHSDATA(ACHSRCT)="6A"_ACHSDOCN_ACHSTOS2_$PIECE(ACHSDOCR,U,2)_"6"_ACHSFAC_ACHSHRN_ACHSEIN_ACHSPTYP_ACHSFED_ACHSCN_ACHSCAN_ACHSOBJC_ACHSDCR_$JUSTIFY("",10)
+16 ;
+17 SET X=$PIECE(ACHSDOCR,U,9)
SET X=$PIECE(X,".",1)_$EXTRACT($PIECE(X,".",2)_"00",1,2)
SET ACHSOAMT=$EXTRACT(X+100000000,2,9)
+18 DO IPA^ACHSTX8
+19 SET ACHSIPA=$EXTRACT(ACHSIPA,5,12)
SET ACHSFULP=$SELECT($PIECE(ACHSTRAN,U,5)="P":2,1:1)
SET X=$PIECE(ACHSTRAN,U,3)
+20 IF +X<1
GOTO A3
IF $DATA(^DPT(X))
GOTO A4
A3 ;
+1 SET ACHSLNAM=$JUSTIFY("",20)
SET ACHSFNAM=$JUSTIFY("",10)
+2 GOTO A5
+3 ;
A4 ;
+1 SET ACHSLNAM=$EXTRACT($PIECE($PIECE($GET(^DPT(X,0)),U),",")_$JUSTIFY("",20),1,20)
SET ACHSFNAM=$EXTRACT($PIECE($PIECE($GET(^DPT(X,0)),U),",",2)_$JUSTIFY("",10),1,10)
A5 ;
+1 SET ACHSWKLD=$EXTRACT(+$PIECE(ACHSTRAN,U,9)+1000,2,4)
SET ACHSDOS=$PIECE(ACHSTRAN,U,10)
IF ACHSDOS=""
SET ACHSDOS=" "
+2 SET X=$PIECE(ACHSTRAN,U,8)
SET X=$PIECE(X,".",1)_$EXTRACT($PIECE(X,".",2)_"00",1,2)
SET ACHSTHRD=$EXTRACT(X+100000000,2,9)
+3 SET ACHSRCT=ACHSRCT+1
+4 SET ^ACHSDATA(ACHSRCT)="6B"_ACHSOAMT_ACHSIPA_ACHSFULP_ACHSLNAM_ACHSFNAM_ACHSDOS_ACHSWKLD_ACHSTHRD_$JUSTIFY("",14)
+5 ;
+6 SET ACHSRTYP(6)=ACHSRTYP(6)+1
+7 IF ACHSRTYP(6)#10=0
WRITE $JUSTIFY(ACHSRTYP(6),8)
+8 GOTO A2
+9 ;
END ;
+1 KILL ACHSCN,ACHSDCR,ACHSDOCN,ACHSDOS,ACHSFNAM,ACHSFULP,ACHSHRN,ACHSIPA,ACHSLNAM,ACHSOAMT,ACHSSCC,ACHSTRAN,ACHSWKLD,ACHSTOS,ACHSPTYP
+2 SET ACHSROUT=ACHSRCT
+3 GOTO ^ACHSTX7
+4 ;
