- 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 ;
