ACDFLAT2.m

ACDFLAT2 ;IHS/ADC/EDE/KML - GENERATE FLAT RECORDS;

 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998

 ;

 ; This routine generates flat ascii records from one cdmis visit.

 ;

FLAT(ACDVIEN,ACDARRAY) ; EP-SET FLAT RECORDS INTO ARRAY

 ; i $$flat^acdflat2(cdmis_visit_ien,.array_name) then flat records

 ; will be in array_name(n)=flat_record where n=1:1 and Q value will

 ; be the number of entries in array_name.

 ;

 ; fields set into array so flat record can be built left to right

 ; which is a must if any value shorter than specified by set $E

 ;

 NEW ACDFREC,ACDN0,ACDRCTR,X,Y

 S ACDRCTR=0

 G:'$D(^ACDVIS(ACDVIEN,0)) FLATX  ;      corrupt database or bad ptr

 S ACDN0=^ACDVIS(ACDVIEN,0)

 K ACDARRAY,ACDF ;             kill caller array + local field array

 S ACDF(1,6)=ACD6DIG ;                       asufac code

 S ACDF(7,13)=$P(ACDN0,U) ;                  visit date

 S Y=$P(ACDN0,U,2) ;                         component ptr

 S:Y ACDF(14,16)=$P($G(^ACDCOMP(Y,0)),U,2) ; component code

 S ACDF(17)=$P(ACDN0,U,7) ;                  component type

 S ACDF(18,19)=$P(ACDN0,U,4) ;               type contact

 S Y=$P(ACDN0,U,3) ;                         primary provider ptr

 S:Y ACDF(127,132)=$P($G(^VA(200,Y,9999999)),U,9) ; adc

 ;S:Y ACDF(127,132)=$P($G(^DIC(6,Y,9999999)),U,9) ; adc

 ;

 D PATIENT ;                           set patient related fields

 ;

 D FILESFT ;                           do file shift for rest of data

 ;

FLATX ; EXIT

 Q ACDRCTR

 ;

PATIENT ; PATIENT RELATED FIELDS

 NEW ACDPIEN

 S ACDPIEN=$P(ACDN0,U,5) ;                 patient pointer

 Q:'ACDPIEN  ;                             no patient pointer

 Q:'$D(^DPT(ACDPIEN,0))  ;                 corrupt database

 Q:'$D(^AUPNPAT(ACDPIEN,0))  ;             corrupt database

 S ACDF(20,31)=$$ENC^AUPNPAT(ACDPIEN) ;    patient id

 S ACDF(32)=$P(^DPT(ACDPIEN,0),U,2) ;      sex

 S ACDF(33,39)=$P(^DPT(ACDPIEN,0),U,3) ;   dob

 S Y=$P($G(^AUPNPAT(ACDPIEN,11)),U,17) ;   community ptr

 S:Y ACDF(40,46)=$P($G(^AUTTCOM(Y,0)),U,8) ; stctycom code

 S Y=$P($G(^AUPNPAT(ACDPIEN,11)),U,8) ;    tribe ptr

 S:Y ACDF(47,49)=$P($G(^AUTTTRI(Y,0)),U,2) ; tribe code

 ;

 NEW ACDVDT

 S ACDVDT=$P(ACDN0,U)

 S X=$$MCR^AUPNPAT(ACDPIEN,ACDVDT)

 S ACDF(50)=$S(X:"Y",1:"N") ;              medicare eligible

 S X=$$MCD^AUPNPAT(ACDPIEN,ACDVDT)

 S ACDF(51)=$S(X:"Y",1:"N") ;              medicaid eligible

 S X=$$PI^AUPNPAT(ACDPIEN,ACDVDT)

 S ACDF(52)=$S(X:"Y",1:"N") ;              private insurance

 Q

 ;

FILESFT ; SHIFT TO SUBORDINATE FILE FOR REST OF DATA

 D FILESFT^ACDFLAT3

 Q

ACDFLAT2  ;IHS/ADC/EDE/KML - GENERATE FLAT RECORDS;

 +1       ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998

 +2       ;

 +3       ; This routine generates flat ascii records from one cdmis visit.

 +4       ;

FLAT(ACDVIEN,ACDARRAY) ; EP-SET FLAT RECORDS INTO ARRAY

 +1       ; i $$flat^acdflat2(cdmis_visit_ien,.array_name) then flat records

 +2       ; will be in array_name(n)=flat_record where n=1:1 and Q value will

 +3       ; be the number of entries in array_name.

 +4       ;

 +5       ; fields set into array so flat record can be built left to right

 +6       ; which is a must if any value shorter than specified by set $E

 +7       ;

 +8        NEW ACDFREC,ACDN0,ACDRCTR,X,Y

 +9        SET ACDRCTR=0

 +10      ;      corrupt database or bad ptr

           IF '$DATA(^ACDVIS(ACDVIEN,0))

               GOTO FLATX

 +11       SET ACDN0=^ACDVIS(ACDVIEN,0)

 +12      ;             kill caller array + local field array

           KILL ACDARRAY,ACDF

 +13      ;                       asufac code

           SET ACDF(1,6)=ACD6DIG

 +14      ;                  visit date

           SET ACDF(7,13)=$PIECE(ACDN0,U)

 +15      ;                         component ptr

           SET Y=$PIECE(ACDN0,U,2)

 +16      ; component code

           IF Y

               SET ACDF(14,16)=$PIECE($GET(^ACDCOMP(Y,0)),U,2)

 +17      ;                  component type

           SET ACDF(17)=$PIECE(ACDN0,U,7)

 +18      ;               type contact

           SET ACDF(18,19)=$PIECE(ACDN0,U,4)

 +19      ;                         primary provider ptr

           SET Y=$PIECE(ACDN0,U,3)

 +20      ; adc

           IF Y

               SET ACDF(127,132)=$PIECE($GET(^VA(200,Y,9999999)),U,9)

 +21      ;S:Y ACDF(127,132)=$P($G(^DIC(6,Y,9999999)),U,9) ; adc

 +22      ;

 +23      ;                           set patient related fields

           DO PATIENT

 +24      ;

 +25      ;                           do file shift for rest of data

           DO FILESFT

 +26      ;

FLATX     ; EXIT

 +1        QUIT ACDRCTR

 +2       ;

PATIENT   ; PATIENT RELATED FIELDS

 +1        NEW ACDPIEN

 +2       ;                 patient pointer

           SET ACDPIEN=$PIECE(ACDN0,U,5)

 +3       ;                             no patient pointer

           IF 'ACDPIEN

               QUIT 

 +4       ;                 corrupt database

           IF '$DATA(^DPT(ACDPIEN,0))

               QUIT 

 +5       ;             corrupt database

           IF '$DATA(^AUPNPAT(ACDPIEN,0))

               QUIT 

 +6       ;    patient id

           SET ACDF(20,31)=$$ENC^AUPNPAT(ACDPIEN)

 +7       ;      sex

           SET ACDF(32)=$PIECE(^DPT(ACDPIEN,0),U,2)

 +8       ;   dob

           SET ACDF(33,39)=$PIECE(^DPT(ACDPIEN,0),U,3)

 +9       ;   community ptr

           SET Y=$PIECE($GET(^AUPNPAT(ACDPIEN,11)),U,17)

 +10      ; stctycom code

           IF Y

               SET ACDF(40,46)=$PIECE($GET(^AUTTCOM(Y,0)),U,8)

 +11      ;    tribe ptr

           SET Y=$PIECE($GET(^AUPNPAT(ACDPIEN,11)),U,8)

 +12      ; tribe code

           IF Y

               SET ACDF(47,49)=$PIECE($GET(^AUTTTRI(Y,0)),U,2)

 +13      ;

 +14       NEW ACDVDT

 +15       SET ACDVDT=$PIECE(ACDN0,U)

 +16       SET X=$$MCR^AUPNPAT(ACDPIEN,ACDVDT)

 +17      ;              medicare eligible

           SET ACDF(50)=$SELECT(X:"Y",1:"N")

 +18       SET X=$$MCD^AUPNPAT(ACDPIEN,ACDVDT)

 +19      ;              medicaid eligible

           SET ACDF(51)=$SELECT(X:"Y",1:"N")

 +20       SET X=$$PI^AUPNPAT(ACDPIEN,ACDVDT)

 +21      ;              private insurance

           SET ACDF(52)=$SELECT(X:"Y",1:"N")

 +22       QUIT 

 +23      ;

FILESFT   ; SHIFT TO SUBORDINATE FILE FOR REST OF DATA

 +1        DO FILESFT^ACDFLAT3

 +2        QUIT