ACHSTXFT.m

ACHSTXFT ; IHS/OIT/FCJ - EXPORT DATA - RECORD 2U(UFMS)FOR TESTING OF LIVE DATA

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

 ;ACHS*3.1*13 IHS/OIT/FCJ NEW ROUTINE

 ;This routine is being used to generate test data for UFMS from live data

 ;Will no longer be needed once UFMS has gone live

 ;

S1 ;EP FROM ACHSTX2

 S ACHSCTYP=""

 S ACHSDEST=$P(ACHSDOCR,U,17),ACHSCTY=ACHSTY

 S ACHSDFY=$P(ACHSDOCR,U,27),X1=$E($P(ACHSDOCR,U,27),4)  ;Four digit FY

 D FYCVT^ACHSFU

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

 S X=$P($G(^ACHSF(DUZ(2),"D",2)),U,9) I X S ACHSCTYP=$P($G(^ACHSCTYP(X,0)),U,2)  ;CONTRACT PURCHASE TYPE

 S:$L(ACHSCTYP)=0 ACHSCTYP=" "

 S ACHSPROV=$P(ACHSDOCR,U,8)

 S:ACHSFED="" ACHSFED=" "

 S ACHSEIN=$TR($P(^AUTTVNDR(ACHSPROV,11),U,13)," -,+","")

 I ACHSEIN="" S ACHSEIN=$TR($P(^AUTTVNDR(ACHSPROV,11),U)_$P(^AUTTVNDR(ACHSPROV,11),U,2)," -,+","")

 S X=$L(ACHSEIN) I X'=12 F I=1:1:12-X  S ACHSEIN=ACHSEIN_" "

 S ACHSDUNS=$P(^AUTTVNDR(ACHSPROV,0),U,7) S X=$L(ACHSDUNS) I X'=13 F I=1:1:13-X  S ACHSDUNS=ACHSDUNS_" "

 ;SET ACHSDATA

 S ACHSRCT=ACHSRCT+1         ;RECORD COUNT

 S ACHSRTYP(8)=ACHSRTYP(8)+1

 S ^ACHSDATA(ACHSRCT)="U2"_ACHSEFDT_ACHSCDE_$S(ACHSTOS=1:323,ACHSTOS=2:324,ACHSTOS=3:325,1:"")_"HHSI"_ACHSARCO_ACHSDFY_ACHSXLOC_$P(ACHSDOCR,U)_ACHSCTYP_$J("",3)_"1"_X1

 S ^ACHSDATA(ACHSRCT)=^ACHSDATA(ACHSRCT)_ACHSCAN_ACHSOBJC_ACHSIPA_ACHSFED_ACHSEIN_$J("",54)_$E(ACHSDFY,3,4)_ACHSDEST_" "_ACHSXLOC_ACHSDUNS_$J("",10)

 ;

 I $L(^ACHSDATA(ACHSRCT))'=161 W !!,*7,*7,"A DHR RECORD WAS PRODUCED THAT WAS NOT 161 CHARACTERS IN LENGTH:",!!,^(ACHSRCT),!,*7,*7 S ACHSERR=1

 ;

CVTEND1 ;

 W $J(ACHSRCT,8)

 S ACHSROUT=ACHSRCT

 S:ACHSRCT>2 ACHSROUT=ACHSRCT

 K ACHSDUNS,X1,ACHSDFY,ACHSEIN

 Q

 ;

ACHSTXFT  ; IHS/OIT/FCJ - EXPORT DATA - RECORD 2U(UFMS)FOR TESTING OF LIVE DATA

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

 +2       ;ACHS*3.1*13 IHS/OIT/FCJ NEW ROUTINE

 +3       ;This routine is being used to generate test data for UFMS from live data

 +4       ;Will no longer be needed once UFMS has gone live

 +5       ;

S1        ;EP FROM ACHSTX2

 +1        SET ACHSCTYP=""

 +2        SET ACHSDEST=$PIECE(ACHSDOCR,U,17)

           SET ACHSCTY=ACHSTY

 +3       ;Four digit FY

           SET ACHSDFY=$PIECE(ACHSDOCR,U,27)

           SET X1=$EXTRACT($PIECE(ACHSDOCR,U,27),4)

 +4        DO FYCVT^ACHSFU

 +5       ;AREA CONTRACTING NO.

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

 +6       ;CONTRACT PURCHASE TYPE

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

           IF X

               SET ACHSCTYP=$PIECE($GET(^ACHSCTYP(X,0)),U,2)

 +7        IF $LENGTH(ACHSCTYP)=0

               SET ACHSCTYP=" "

 +8        SET ACHSPROV=$PIECE(ACHSDOCR,U,8)

 +9        IF ACHSFED=""

               SET ACHSFED=" "

 +10       SET ACHSEIN=$TRANSLATE($PIECE(^AUTTVNDR(ACHSPROV,11),U,13)," -,+","")

 +11       IF ACHSEIN=""

               SET ACHSEIN=$TRANSLATE($PIECE(^AUTTVNDR(ACHSPROV,11),U)_$PIECE(^AUTTVNDR(ACHSPROV,11),U,2)," -,+","")

 +12       SET X=$LENGTH(ACHSEIN)

           IF X'=12

               FOR I=1:1:12-X

                   SET ACHSEIN=ACHSEIN_" "

 +13       SET ACHSDUNS=$PIECE(^AUTTVNDR(ACHSPROV,0),U,7)

           SET X=$LENGTH(ACHSDUNS)

           IF X'=13

               FOR I=1:1:13-X

                   SET ACHSDUNS=ACHSDUNS_" "

 +14      ;SET ACHSDATA

 +15      ;RECORD COUNT

           SET ACHSRCT=ACHSRCT+1

 +16       SET ACHSRTYP(8)=ACHSRTYP(8)+1

 +17       SET ^ACHSDATA(ACHSRCT)="U2"_ACHSEFDT_ACHSCDE_$SELECT(ACHSTOS=1:323,ACHSTOS=2:324,ACHSTOS=3:325,1:"")_"HHSI"_ACHSARCO_ACHSDFY_ACHSXLOC_$PIECE(ACHSDOCR,U)_ACHSCTYP_$JUSTIFY("",3)_"1"_X1

 +18       SET ^ACHSDATA(ACHSRCT)=^ACHSDATA(ACHSRCT)_ACHSCAN_ACHSOBJC_ACHSIPA_ACHSFED_ACHSEIN_$JUSTIFY("",54)_$EXTRACT(ACHSDFY,3,4)_ACHSDEST_" "_ACHSXLOC_ACHSDUNS_$JUSTIFY("",10)

 +19      ;

 +20       IF $LENGTH(^ACHSDATA(ACHSRCT))'=161

               WRITE !!,*7,*7,"A DHR RECORD WAS PRODUCED THAT WAS NOT 161 CHARACTERS IN LENGTH:",!!,^(ACHSRCT),!,*7,*7

               SET ACHSERR=1

 +21      ;

CVTEND1   ;

 +1        WRITE $JUSTIFY(ACHSRCT,8)

 +2        SET ACHSROUT=ACHSRCT

 +3        IF ACHSRCT>2

               SET ACHSROUT=ACHSRCT

 +4        KILL ACHSDUNS,X1,ACHSDFY,ACHSEIN

 +5        QUIT 

 +6       ;