ACDFLAT4 ;IHS/ADC/EDE/KML - GENERATE FLAT RECORDS;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;
; This routine generates flat ascii records from one cdmis
; prevention record.
;
FLAT(ACDPIEN,ACDARRAY) ; EP-SET FLAT RECORDS INTO ARRAY
; i $$flat^acdflat4(cdmis_prevention_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(^ACDPD(ACDPIEN,0)) FLATX ; corrupt database or bad ptr
S ACDN0=^ACDPD(ACDPIEN,0)
K ACDARRAY,ACDF ; kill caller array + local field array
S ACDF(1,6)=ACD6DIG ; asufac code
S ACDF(7,13)=$P(ACDN0,U) ; prevention 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,3) ; component type
S ACDF(18,19)="PR" ; type contact
S Y=$P(ACDN0,U,5) ; 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 PR
D SETARRAY
;
FLATX ; EXIT
Q ACDRCTR
;
PR ;
NEW ACDN0
S ACDPDIEN=0
F S ACDPDIEN=$O(^ACDPD(ACDPIEN,1,ACDPDIEN)) Q:'ACDPDIEN D PR2
Q
;
PR2 ; PROCESS ONE PR DAY ENTRY
; killing of ACDF(n) necessary because one flat record is
; generated for each PR entry and all fields remain the same except
; those set here. Fields may be missing.
;
Q:'$D(^ACDPD(ACDPIEN,1,ACDPDIEN,0)) ; corrupt database
S ACDN0=^ACDPD(ACDPIEN,1,ACDPDIEN,0)
S X=$P(ACDN0,U) ; day
K ACDF(106)
S:X'="" ACDF(106,107)=$$LZERO^ACDFUNC(X,2) ;left zero fill it
S X=$P(ACDN0,U,2) ; prv act
S X=$G(^ACDPREV(9002170.9,X,0)),X=$P(X,U,2)
K ACDF(175)
S:X'="" ACDF(175,176)=$$LZERO^ACDFUNC(X,2) ;left zero fill it
S X=$P(ACDN0,U,3) ; loc
S X=$G(^ACDLOT(X,0)),X=$P(X,U,2)
K ACDF(177)
S:X'="" ACDF(177,178)=$$LZERO^ACDFUNC(X,2) ;left zero fill it
S X=$P(ACDN0,U,4) ; target
K ACDF(179)
S:X'="" ACDF(179)=X
S X=$P(ACDN0,U,5) ; number reached
K ACDF(180)
S:X'="" ACDF(180,185)=$$LZERO^ACDFUNC(X,6) ;left zero fill it
S X=$P(ACDN0,U,6) ; outcome
K ACDF(186)
S:X'="" ACDF(186,187)=X
S X=$P(ACDN0,U,7) ; community education
K ACDF(188)
S:X'="" ACDF(188)=X
S X=$P(ACDN0,U,8) ; hours
K ACDF(189)
S:X'="" ACDF(189,193)=$$LBLNK^ACDFUNC(X,5) ;left blank fill it
NEW %,A
K ACDF(133),ACDF(139),ACDF(145)
S ACDMIEN=0
F ACDLC=1:1:3 S ACDMIEN=$O(^ACDPD(ACDPIEN,1,ACDPDIEN,"PRV",ACDMIEN)) Q:'ACDMIEN D
. Q:'$D(^ACDPD(ACDPIEN,1,ACDPDIEN,"PRV",ACDMIEN,0)) ; corrupt database
. S Y=$P(^ACDPD(ACDPIEN,1,ACDPDIEN,"PRV",ACDMIEN,0),U) ;provider ptr
. S %=ACDLC
. S A=$S(%=1:133,%=2:139,1:145)
. S ACDF(A,A+5)=$P($G(^VA(200,Y,9999999)),U,9) ; adc
.;S ACDF(A,A+5)=$P($G(^DIC(6,Y,9999999)),U,9) ; adc
. Q
Q
;
SETARRAY ; SET RECORD INTO ARRAY
S ACDFREC=""
; set values positionally ,left to right, into flat record from array
F X=0:0 S X=$O(ACDF(X)) Q:X="" K V S Y=$O(ACDF(X,0)) S:'Y Y=X,V=ACDF(X) S:'$D(V) V=ACDF(X,Y) S @("$E(ACDFREC,"_X_","_Y_")=V")
S:$L(ACDFREC)<200 $E(ACDFREC,200)=" " ; force fixed length
S ACDRCTR=ACDRCTR+1
S ACDARRAY(ACDRCTR)=ACDFREC
D:$D(ACDFTEST) EP^XBCLM(ACDFREC) ; show record for test
Q
ACDFLAT4 ;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
+4 ; prevention record.
+5 ;
FLAT(ACDPIEN,ACDARRAY) ; EP-SET FLAT RECORDS INTO ARRAY
+1 ; i $$flat^acdflat4(cdmis_prevention_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(^ACDPD(ACDPIEN,0))
GOTO FLATX
+11 SET ACDN0=^ACDPD(ACDPIEN,0)
+12 ; kill caller array + local field array
KILL ACDARRAY,ACDF
+13 ; asufac code
SET ACDF(1,6)=ACD6DIG
+14 ; prevention 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,3)
+18 ; type contact
SET ACDF(18,19)="PR"
+19 ; primary provider ptr
SET Y=$PIECE(ACDN0,U,5)
+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 DO PR
+24 DO SETARRAY
+25 ;
FLATX ; EXIT
+1 QUIT ACDRCTR
+2 ;
PR ;
+1 NEW ACDN0
+2 SET ACDPDIEN=0
+3 FOR
SET ACDPDIEN=$ORDER(^ACDPD(ACDPIEN,1,ACDPDIEN))
IF 'ACDPDIEN
QUIT
DO PR2
+4 QUIT
+5 ;
PR2 ; PROCESS ONE PR DAY ENTRY
+1 ; killing of ACDF(n) necessary because one flat record is
+2 ; generated for each PR entry and all fields remain the same except
+3 ; those set here. Fields may be missing.
+4 ;
+5 ; corrupt database
IF '$DATA(^ACDPD(ACDPIEN,1,ACDPDIEN,0))
QUIT
+6 SET ACDN0=^ACDPD(ACDPIEN,1,ACDPDIEN,0)
+7 ; day
SET X=$PIECE(ACDN0,U)
+8 KILL ACDF(106)
+9 ;left zero fill it
IF X'=""
SET ACDF(106,107)=$$LZERO^ACDFUNC(X,2)
+10 ; prv act
SET X=$PIECE(ACDN0,U,2)
+11 SET X=$GET(^ACDPREV(9002170.9,X,0))
SET X=$PIECE(X,U,2)
+12 KILL ACDF(175)
+13 ;left zero fill it
IF X'=""
SET ACDF(175,176)=$$LZERO^ACDFUNC(X,2)
+14 ; loc
SET X=$PIECE(ACDN0,U,3)
+15 SET X=$GET(^ACDLOT(X,0))
SET X=$PIECE(X,U,2)
+16 KILL ACDF(177)
+17 ;left zero fill it
IF X'=""
SET ACDF(177,178)=$$LZERO^ACDFUNC(X,2)
+18 ; target
SET X=$PIECE(ACDN0,U,4)
+19 KILL ACDF(179)
+20 IF X'=""
SET ACDF(179)=X
+21 ; number reached
SET X=$PIECE(ACDN0,U,5)
+22 KILL ACDF(180)
+23 ;left zero fill it
IF X'=""
SET ACDF(180,185)=$$LZERO^ACDFUNC(X,6)
+24 ; outcome
SET X=$PIECE(ACDN0,U,6)
+25 KILL ACDF(186)
+26 IF X'=""
SET ACDF(186,187)=X
+27 ; community education
SET X=$PIECE(ACDN0,U,7)
+28 KILL ACDF(188)
+29 IF X'=""
SET ACDF(188)=X
+30 ; hours
SET X=$PIECE(ACDN0,U,8)
+31 KILL ACDF(189)
+32 ;left blank fill it
IF X'=""
SET ACDF(189,193)=$$LBLNK^ACDFUNC(X,5)
+33 NEW %,A
+34 KILL ACDF(133),ACDF(139),ACDF(145)
+35 SET ACDMIEN=0
+36 FOR ACDLC=1:1:3
SET ACDMIEN=$ORDER(^ACDPD(ACDPIEN,1,ACDPDIEN,"PRV",ACDMIEN))
IF 'ACDMIEN
QUIT
Begin DoDot:1
+37 ; corrupt database
IF '$DATA(^ACDPD(ACDPIEN,1,ACDPDIEN,"PRV",ACDMIEN,0))
QUIT
+38 ;provider ptr
SET Y=$PIECE(^ACDPD(ACDPIEN,1,ACDPDIEN,"PRV",ACDMIEN,0),U)
+39 SET %=ACDLC
+40 SET A=$SELECT(%=1:133,%=2:139,1:145)
+41 ; adc
SET ACDF(A,A+5)=$PIECE($GET(^VA(200,Y,9999999)),U,9)
+42 ;S ACDF(A,A+5)=$P($G(^DIC(6,Y,9999999)),U,9) ; adc
+43 QUIT
End DoDot:1
+44 QUIT
+45 ;
SETARRAY ; SET RECORD INTO ARRAY
+1 SET ACDFREC=""
+2 ; set values positionally ,left to right, into flat record from array
+3 FOR X=0:0
SET X=$ORDER(ACDF(X))
IF X=""
QUIT
KILL V
SET Y=$ORDER(ACDF(X,0))
IF 'Y
SET Y=X
SET V=ACDF(X)
IF '$DATA(V)
SET V=ACDF(X,Y)
SET @("$E(ACDFREC,"_X_","_Y_")=V")
+4 ; force fixed length
IF $LENGTH(ACDFREC)<200
SET $EXTRACT(ACDFREC,200)=" "
+5 SET ACDRCTR=ACDRCTR+1
+6 SET ACDARRAY(ACDRCTR)=ACDFREC
+7 ; show record for test
IF $DATA(ACDFTEST)
DO EP^XBCLM(ACDFREC)
+8 QUIT
