ACKQCDD2 ;AUG/JLTP BIR/PTD HCIOFO/AG-Generate A&SP Service CDR for Division - CONTINUED ; [05/15/96 9:30 ]
;;3.0;QUASAR;;Feb 11, 2000
;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
INDCAT(ACKCDR) ;Enter hours for CDR account.
N DIR,Y,CDR,X
INDCAT2 K DIRUT,DUOUT,DTOUT,DIR S X=ACKCDR
S DIR(0)="N^0:"_ACKRTH,CDR=$P(^ACK(509850,X,0),U)_" "_$P(^(0),U,2)
S DIR("A")="Enter Hours for "_CDR
S DIR("??")="^W !!,""Enter the number of hours that you wish to charge to CDR"",!,""account "",CDR,""."""
D ^DIR
I Y?1"^"1.E W !,"Jumping not allowed.",! G INDCAT2
Q:$D(DIRUT)
S ^TMP("ACKQCDD",$J,"ACKH",+CDR)=Y,ACKRTH=ACKRTH-Y
Q
PASS ;Enter hours for pass-through account.
N DIC,DIR,X,Y,CDR
PASS2 S DIC="^ACK(509850,",DIC("A")="Select Pass-Through Account: "
S DIC("S")="I $P(^(0),U,3)=""P""",DIC(0)="AEMQZ"
D ^DIC K DIC
I X?1"^"1.E W !,"Jumping not allowed.",! G PASS2
I Y<0 S DIRUT=1 Q
S CDR=+$P(Y,U,2),CDR(0)=$P(Y(0),U,2)
PASS3 I $D(^TMP("ACKQCDD",$J,"ACKH",CDR)) S DIR("B")=^TMP("ACKQCDD",$J,"ACKH",CDR)
S DIR(0)="N^0:"_ACKRTH,DIR("A")="Enter Hours for "_CDR(0)
S DIR("??")="^W !!,""Enter the number of hours to charge to "",CDR(0)"
D ^DIR
I Y?1"^"1.E W !,"Jumping not allowed.",! G PASS3
Q:$D(DIRUT)
S ^TMP("ACKQCDD",$J,"ACKH",CDR)=Y S:$D(DIR("B")) ACKRTH=ACKRTH+DIR("B") S ACKRTH=ACKRTH-Y
Q
DISREM ;DISTRIBUTE REMAINING HOURS
N I,X
S I=0 F S I=$O(ACKTCH(I)) Q:'I D
.S X=(ACKTCH(I)/ACKTCH)*ACKRTH,ACKTCH(I)=ACKTCH(I)+X
Q
PERCENT ;CONVERT ALL VALUES TO %
N I,X
S ACKTP=0
S I=0 F S I=$O(^TMP("ACKQCDD",$J,"ACKH",I)) Q:'I D
. S X=^TMP("ACKQCDD",$J,"ACKH",I)/ACKTPH*100
. S ^TMP("ACKQCDD",$J,"ACKH",I)=X,ACKTP=ACKTP+X
S I=0 F S I=$O(ACKTCH(I)) Q:'I D
. S ^TMP("ACKQCDD",$J,"ACKH",I)=ACKTCH(I)/ACKTPH*100
. S ACKTP=ACKTP+^TMP("ACKQCDD",$J,"ACKH",I)
K ACKTCH
Q
;
CLINH ;Calculate number of clinic hours & student training
; (.12) by CDR series. See README at end.
; requires ACKSD - start of date range
; ACKED - end of date range
; ACKDIV - selected division
N ACKCDR,ACKD,I,ACKV,ACKMINS
K ACKTCH,ACKTSH S (ACKTCH,ACKTSH)=0
;Loop through selected date range and get total minutes and total
; student minutes
F ACKD=(ACKSD-.1):0 S ACKD=$O(^ACK(509850.6,"B",ACKD)) Q:'ACKD!(ACKD>(ACKED+.9)) D
.S ACKV=0 F S ACKV=$O(^ACK(509850.6,"B",ACKD,ACKV)) Q:'ACKV D
.. ; check division
.. S ACKVDIV=$$GET1^DIQ(509850.6,ACKV_",",60,"I")
.. I ACKVDIV'=ACKDIV Q
..;Get TIME SPENT and CDR#. Student present? YES, increment ACKTSH array; else increment ACKTCH array.
..S ACKMINS=+$P(^ACK(509850.6,ACKV,0),U,7)
..S ACK2=^ACK(509850.6,ACKV,2)
..S ACKCDR=+$P(ACK2,U,2),ACKCDRN=+$P($G(^ACK(509850,ACKCDR,0)),U,1)
..I $P(ACK2,U,4) D ;student present
...S ACKTSH=ACKTSH+ACKMINS
...S ACKTSH($E(ACKCDRN,1,2))=$G(ACKTSH($E(ACKCDRN,1,2)))+ACKMINS
..I '$P(ACK2,U,4) D ;student not present
...S ACKTCH=ACKTCH+ACKMINS
...S ACKTCH(ACKCDRN)=$G(ACKTCH(ACKCDRN))+ACKMINS
;
;Convert minutes to hours - total time (less student)
S ACKTCH=ACKTCH/60
S ACKCDRN=0 F S ACKCDRN=$O(ACKTCH(ACKCDRN)) Q:'ACKCDRN D
. S ACKTCH(ACKCDRN)=ACKTCH(ACKCDRN)/60
;Convert minutes to hours - student time, and move into ^TMP
S ACKTSH=ACKTSH/60
S ACKCDRN=0 F S ACKCDRN=$O(ACKTSH(ACKCDRN)) Q:'ACKCDRN D
. S ACKTSH(ACKCDRN)=ACKTSH(ACKCDRN)/60
. I (ACKCDRN<21)!(ACKCDRN>27) D
.. S ^TMP("ACKQCDD",$J,"ACKH",ACKCDRN_"00.12")=+ACKTSH(ACKCDRN)
. I ACKCDRN'<21,ACKCDRN'>27 D
.. S ^TMP("ACKQCDD",$J,"ACKH",2800.12)=+ACKTSH(ACKCDRN)
Q
;
TPH ;Ask for Total Paid Hours.
N DIR,X,Y
TPH2 K DTOUT,DUOUT,DIRUT,DIR
S DIR(0)="N^1:9999",DIR("A")="Enter Total Paid Hours"
S DIR("?")="Enter a number between 1 and 9999."
S DIR("??")="^D TPH^ACKQCDD1"
W ! D ^DIR
I Y?1"^"1.E W !,"Jumping not allowed.",! G TPH2
S ACKTPH=+Y
Q
INDEX ;Build ^TMP arrays in category and CDR# order.
N I,CAT,CDR
S I=0 F S I=$O(^ACK(509850,I)) Q:'I D
. S CDR=^ACK(509850,I,0),CAT=$P(CDR,U,4)
. S ^TMP("ACKQCDD",$J,"ACKCAT",CAT,+CDR)=$P(CDR,U,1,2)
. S:ACKSAV ^TMP("ACKQCDD",$J,"ACKNDX",+CDR)=$P(CDR,U)
Q
SAVE ;
N IFN,M
S IFN=+$$SITE^VASITE_$E(ACKMO,1,5)
;
; if there is data for the selected month/division then ask to delete
I $O(^ACK(509850.7,IFN,5,ACKDIV,4,0)) D Q:$D(DIRUT)
.K DIR,X,Y S DIR(0)="Y",DIR("A")="Delete existing CDR data and regenerate the CDR for "_ACKXRNG,DIR("B")="NO"
.S DIR("?")="Enter YES to delete and regenerate the CDR, otherwise enter NO.",DIR("??")="^D REGEN^ACKQHLP1"
.W ! D ^DIR K DIR S:Y=0 DIRUT=1 Q:$D(DIRUT)
.D KILLOLD ;remove old data for this month and division
;
; now (re)create the file
L +^ACK(509850.7,IFN)
; check the headers exist
I '$D(^ACK(509850.7,IFN,0)) D CRE8HDR
I '$D(^ACK(509850.7,IFN,5,ACKDIV,0)) D CRE8DIV
;
; file the CDR total paid hours
S DIE="^ACK(509850.7,"_IFN_",5,",DA=ACKDIV,DA(1)=IFN,DR="5.05////"_ACKTPH D ^DIE K DIE,DA,DR
;
; update CDR percentages
S CDR=0 F S CDR=$O(^TMP("ACKQCDD",$J,"ACKH",CDR)) Q:'CDR I ^TMP("ACKQCDD",$J,"ACKH",CDR) D
.S DIC="^ACK(509850.7,"_IFN_",5,"_ACKDIV_",4,",DIC(0)="L"
.S DLAYGO=509850.75,X=$P(^TMP("ACKQCDD",$J,"ACKNDX",CDR),U),DINUM=+X
.S DIC("P")=$P(^DD(509850.75,5.8,0),U,2),DA(2)=IFN,DA(1)=ACKDIV
.K DD,DO D FILE^DICN K DA
.S DIE="^ACK(509850.7,"_IFN_",5,"_ACKDIV_",4,"
.S DA=+CDR,DA(1)=ACKDIV,DA(2)=IFN
.S DR="54.02////"_$J(^TMP("ACKQCDD",$J,"ACKH",+CDR),0,9)
.D ^DIE
;
; end
L -^ACK(509850.7,IFN)
Q
KILLOLD ;kill existing CDR data for the selected month and division
S DIK="^ACK(509850.7,"_IFN_",5,"_ACKDIV_",4,",DA(2)=IFN,DA(1)=ACKDIV
; loop for each CDR and kill
S SUB=0
F S SUB=$O(^ACK(509850.7,IFN,5,ACKDIV,4,SUB)) Q:'SUB S DA=SUB D ^DIK
; remove the CDR total paid hours field
S DIE="^ACK(509850.7,"_IFN_",5,",DA=ACKDIV,DA(1)=IFN
S DR="5.02///"_"@" D ^DIE K DIE,DA,DR
; if there is no workload for the division for the month then empty the file completely
I '$O(^ACK(509850.7,IFN,5,ACKDIV,1,0)) D
. S DIK="^ACK(509850.7,"_IFN_",5,",DA=ACKDIV,DA(1)=IFN D ^DIK
; end
Q
CRE8HDR ; create a header record for the month
N DIC,DINUM,CDR,DD,DO
S DIC="^ACK(509850.7,",DIC(0)="L",DLAYGO=509850.7
S ACKLAYGO="",X=ACKMO,DINUM=IFN D FILE^DICN
Q
CRE8DIV ; create a header record for the division
N DIC,DINUM,CDR,DD,DO
S DIC="^ACK(509850.7,"_IFN_",5,",DIC(0)="L",DLAYGO=509850.75
S DIC("P")=$P(^DD(509850.7,5,0),U,2)
S ACKLAYGO="",X=ACKDIV,DINUM=ACKDIV,DA=ACKDIV,DA(1)=IFN D FILE^DICN
Q
README ;Instructional Support (.12) Calculation:
;As per Dr. Kyle Dennis 5/13/96. First 2 digits of CDR#
;identify most CDR categories. 11-Medical, 12-Surgical,
;13-Psych, 14-NH, 15-Dom Care, 16-Inter. Care, 17-Psych Rehab.
;The CDR to be credited is: First 2 digits_"00.12"
;CDR range 2110 through 2780 is Outpatient Care 2800.12.
;If site uses 5100 HBHC, site must add 5100.12 to CDR file.
;If site uses 8024 DOD SHARE, site must add 8000.12 to CDR file.
;Ignore CATEGORY 11 and 12 from CDR file (#509850).
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQCDD2 7052 printed Dec 13, 2024@02:31:58 Page 2
ACKQCDD2 ;AUG/JLTP BIR/PTD HCIOFO/AG-Generate A&SP Service CDR for Division - CONTINUED ; [05/15/96 9:30 ]
+1 ;;3.0;QUASAR;;Feb 11, 2000
+2 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
INDCAT(ACKCDR) ;Enter hours for CDR account.
+1 NEW DIR,Y,CDR,X
INDCAT2 KILL DIRUT,DUOUT,DTOUT,DIR
SET X=ACKCDR
+1 SET DIR(0)="N^0:"_ACKRTH
SET CDR=$PIECE(^ACK(509850,X,0),U)_" "_$PIECE(^(0),U,2)
+2 SET DIR("A")="Enter Hours for "_CDR
+3 SET DIR("??")="^W !!,""Enter the number of hours that you wish to charge to CDR"",!,""account "",CDR,""."""
+4 DO ^DIR
+5 IF Y?1"^"1.E
WRITE !,"Jumping not allowed.",!
GOTO INDCAT2
+6 if $DATA(DIRUT)
QUIT
+7 SET ^TMP("ACKQCDD",$JOB,"ACKH",+CDR)=Y
SET ACKRTH=ACKRTH-Y
+8 QUIT
PASS ;Enter hours for pass-through account.
+1 NEW DIC,DIR,X,Y,CDR
PASS2 SET DIC="^ACK(509850,"
SET DIC("A")="Select Pass-Through Account: "
+1 SET DIC("S")="I $P(^(0),U,3)=""P"""
SET DIC(0)="AEMQZ"
+2 DO ^DIC
KILL DIC
+3 IF X?1"^"1.E
WRITE !,"Jumping not allowed.",!
GOTO PASS2
+4 IF Y<0
SET DIRUT=1
QUIT
+5 SET CDR=+$PIECE(Y,U,2)
SET CDR(0)=$PIECE(Y(0),U,2)
PASS3 IF $DATA(^TMP("ACKQCDD",$JOB,"ACKH",CDR))
SET DIR("B")=^TMP("ACKQCDD",$JOB,"ACKH",CDR)
+1 SET DIR(0)="N^0:"_ACKRTH
SET DIR("A")="Enter Hours for "_CDR(0)
+2 SET DIR("??")="^W !!,""Enter the number of hours to charge to "",CDR(0)"
+3 DO ^DIR
+4 IF Y?1"^"1.E
WRITE !,"Jumping not allowed.",!
GOTO PASS3
+5 if $DATA(DIRUT)
QUIT
+6 SET ^TMP("ACKQCDD",$JOB,"ACKH",CDR)=Y
if $DATA(DIR("B"))
SET ACKRTH=ACKRTH+DIR("B")
SET ACKRTH=ACKRTH-Y
+7 QUIT
DISREM ;DISTRIBUTE REMAINING HOURS
+1 NEW I,X
+2 SET I=0
FOR
SET I=$ORDER(ACKTCH(I))
if 'I
QUIT
Begin DoDot:1
+3 SET X=(ACKTCH(I)/ACKTCH)*ACKRTH
SET ACKTCH(I)=ACKTCH(I)+X
End DoDot:1
+4 QUIT
PERCENT ;CONVERT ALL VALUES TO %
+1 NEW I,X
+2 SET ACKTP=0
+3 SET I=0
FOR
SET I=$ORDER(^TMP("ACKQCDD",$JOB,"ACKH",I))
if 'I
QUIT
Begin DoDot:1
+4 SET X=^TMP("ACKQCDD",$JOB,"ACKH",I)/ACKTPH*100
+5 SET ^TMP("ACKQCDD",$JOB,"ACKH",I)=X
SET ACKTP=ACKTP+X
End DoDot:1
+6 SET I=0
FOR
SET I=$ORDER(ACKTCH(I))
if 'I
QUIT
Begin DoDot:1
+7 SET ^TMP("ACKQCDD",$JOB,"ACKH",I)=ACKTCH(I)/ACKTPH*100
+8 SET ACKTP=ACKTP+^TMP("ACKQCDD",$JOB,"ACKH",I)
End DoDot:1
+9 KILL ACKTCH
+10 QUIT
+11 ;
CLINH ;Calculate number of clinic hours & student training
+1 ; (.12) by CDR series. See README at end.
+2 ; requires ACKSD - start of date range
+3 ; ACKED - end of date range
+4 ; ACKDIV - selected division
+5 NEW ACKCDR,ACKD,I,ACKV,ACKMINS
+6 KILL ACKTCH,ACKTSH
SET (ACKTCH,ACKTSH)=0
+7 ;Loop through selected date range and get total minutes and total
+8 ; student minutes
+9 FOR ACKD=(ACKSD-.1):0
SET ACKD=$ORDER(^ACK(509850.6,"B",ACKD))
if 'ACKD!(ACKD>(ACKED+.9))
QUIT
Begin DoDot:1
+10 SET ACKV=0
FOR
SET ACKV=$ORDER(^ACK(509850.6,"B",ACKD,ACKV))
if 'ACKV
QUIT
Begin DoDot:2
+11 ; check division
+12 SET ACKVDIV=$$GET1^DIQ(509850.6,ACKV_",",60,"I")
+13 IF ACKVDIV'=ACKDIV
QUIT
+14 ;Get TIME SPENT and CDR#. Student present? YES, increment ACKTSH array; else increment ACKTCH array.
+15 SET ACKMINS=+$PIECE(^ACK(509850.6,ACKV,0),U,7)
+16 SET ACK2=^ACK(509850.6,ACKV,2)
+17 SET ACKCDR=+$PIECE(ACK2,U,2)
SET ACKCDRN=+$PIECE($GET(^ACK(509850,ACKCDR,0)),U,1)
+18 ;student present
IF $PIECE(ACK2,U,4)
Begin DoDot:3
+19 SET ACKTSH=ACKTSH+ACKMINS
+20 SET ACKTSH($EXTRACT(ACKCDRN,1,2))=$GET(ACKTSH($EXTRACT(ACKCDRN,1,2)))+ACKMINS
End DoDot:3
+21 ;student not present
IF '$PIECE(ACK2,U,4)
Begin DoDot:3
+22 SET ACKTCH=ACKTCH+ACKMINS
+23 SET ACKTCH(ACKCDRN)=$GET(ACKTCH(ACKCDRN))+ACKMINS
End DoDot:3
End DoDot:2
End DoDot:1
+24 ;
+25 ;Convert minutes to hours - total time (less student)
+26 SET ACKTCH=ACKTCH/60
+27 SET ACKCDRN=0
FOR
SET ACKCDRN=$ORDER(ACKTCH(ACKCDRN))
if 'ACKCDRN
QUIT
Begin DoDot:1
+28 SET ACKTCH(ACKCDRN)=ACKTCH(ACKCDRN)/60
End DoDot:1
+29 ;Convert minutes to hours - student time, and move into ^TMP
+30 SET ACKTSH=ACKTSH/60
+31 SET ACKCDRN=0
FOR
SET ACKCDRN=$ORDER(ACKTSH(ACKCDRN))
if 'ACKCDRN
QUIT
Begin DoDot:1
+32 SET ACKTSH(ACKCDRN)=ACKTSH(ACKCDRN)/60
+33 IF (ACKCDRN<21)!(ACKCDRN>27)
Begin DoDot:2
+34 SET ^TMP("ACKQCDD",$JOB,"ACKH",ACKCDRN_"00.12")=+ACKTSH(ACKCDRN)
End DoDot:2
+35 IF ACKCDRN'<21
IF ACKCDRN'>27
Begin DoDot:2
+36 SET ^TMP("ACKQCDD",$JOB,"ACKH",2800.12)=+ACKTSH(ACKCDRN)
End DoDot:2
End DoDot:1
+37 QUIT
+38 ;
TPH ;Ask for Total Paid Hours.
+1 NEW DIR,X,Y
TPH2 KILL DTOUT,DUOUT,DIRUT,DIR
+1 SET DIR(0)="N^1:9999"
SET DIR("A")="Enter Total Paid Hours"
+2 SET DIR("?")="Enter a number between 1 and 9999."
+3 SET DIR("??")="^D TPH^ACKQCDD1"
+4 WRITE !
DO ^DIR
+5 IF Y?1"^"1.E
WRITE !,"Jumping not allowed.",!
GOTO TPH2
+6 SET ACKTPH=+Y
+7 QUIT
INDEX ;Build ^TMP arrays in category and CDR# order.
+1 NEW I,CAT,CDR
+2 SET I=0
FOR
SET I=$ORDER(^ACK(509850,I))
if 'I
QUIT
Begin DoDot:1
+3 SET CDR=^ACK(509850,I,0)
SET CAT=$PIECE(CDR,U,4)
+4 SET ^TMP("ACKQCDD",$JOB,"ACKCAT",CAT,+CDR)=$PIECE(CDR,U,1,2)
+5 if ACKSAV
SET ^TMP("ACKQCDD",$JOB,"ACKNDX",+CDR)=$PIECE(CDR,U)
End DoDot:1
+6 QUIT
SAVE ;
+1 NEW IFN,M
+2 SET IFN=+$$SITE^VASITE_$E(ACKMO,1,5)
+3 ;
+4 ; if there is data for the selected month/division then ask to delete
+5 IF $ORDER(^ACK(509850.7,IFN,5,ACKDIV,4,0))
Begin DoDot:1
+6 KILL DIR,X,Y
SET DIR(0)="Y"
SET DIR("A")="Delete existing CDR data and regenerate the CDR for "_ACKXRNG
SET DIR("B")="NO"
+7 SET DIR("?")="Enter YES to delete and regenerate the CDR, otherwise enter NO."
SET DIR("??")="^D REGEN^ACKQHLP1"
+8 WRITE !
DO ^DIR
KILL DIR
if Y=0
SET DIRUT=1
if $DATA(DIRUT)
QUIT
+9 ;remove old data for this month and division
DO KILLOLD
End DoDot:1
if $DATA(DIRUT)
QUIT
+10 ;
+11 ; now (re)create the file
+12 LOCK +^ACK(509850.7,IFN)
+13 ; check the headers exist
+14 IF '$DATA(^ACK(509850.7,IFN,0))
DO CRE8HDR
+15 IF '$DATA(^ACK(509850.7,IFN,5,ACKDIV,0))
DO CRE8DIV
+16 ;
+17 ; file the CDR total paid hours
+18 SET DIE="^ACK(509850.7,"_IFN_",5,"
SET DA=ACKDIV
SET DA(1)=IFN
SET DR="5.05////"_ACKTPH
DO ^DIE
KILL DIE,DA,DR
+19 ;
+20 ; update CDR percentages
+21 SET CDR=0
FOR
SET CDR=$ORDER(^TMP("ACKQCDD",$JOB,"ACKH",CDR))
if 'CDR
QUIT
IF ^TMP("ACKQCDD",$JOB,"ACKH",CDR)
Begin DoDot:1
+22 SET DIC="^ACK(509850.7,"_IFN_",5,"_ACKDIV_",4,"
SET DIC(0)="L"
+23 SET DLAYGO=509850.75
SET X=$PIECE(^TMP("ACKQCDD",$JOB,"ACKNDX",CDR),U)
SET DINUM=+X
+24 SET DIC("P")=$PIECE(^DD(509850.75,5.8,0),U,2)
SET DA(2)=IFN
SET DA(1)=ACKDIV
+25 KILL DD,DO
DO FILE^DICN
KILL DA
+26 SET DIE="^ACK(509850.7,"_IFN_",5,"_ACKDIV_",4,"
+27 SET DA=+CDR
SET DA(1)=ACKDIV
SET DA(2)=IFN
+28 SET DR="54.02////"_$JUSTIFY(^TMP("ACKQCDD",$JOB,"ACKH",+CDR),0,9)
+29 DO ^DIE
End DoDot:1
+30 ;
+31 ; end
+32 LOCK -^ACK(509850.7,IFN)
+33 QUIT
KILLOLD ;kill existing CDR data for the selected month and division
+1 SET DIK="^ACK(509850.7,"_IFN_",5,"_ACKDIV_",4,"
SET DA(2)=IFN
SET DA(1)=ACKDIV
+2 ; loop for each CDR and kill
+3 SET SUB=0
+4 FOR
SET SUB=$ORDER(^ACK(509850.7,IFN,5,ACKDIV,4,SUB))
if 'SUB
QUIT
SET DA=SUB
DO ^DIK
+5 ; remove the CDR total paid hours field
+6 SET DIE="^ACK(509850.7,"_IFN_",5,"
SET DA=ACKDIV
SET DA(1)=IFN
+7 SET DR="5.02///"_"@"
DO ^DIE
KILL DIE,DA,DR
+8 ; if there is no workload for the division for the month then empty the file completely
+9 IF '$ORDER(^ACK(509850.7,IFN,5,ACKDIV,1,0))
Begin DoDot:1
+10 SET DIK="^ACK(509850.7,"_IFN_",5,"
SET DA=ACKDIV
SET DA(1)=IFN
DO ^DIK
End DoDot:1
+11 ; end
+12 QUIT
CRE8HDR ; create a header record for the month
+1 NEW DIC,DINUM,CDR,DD,DO
+2 SET DIC="^ACK(509850.7,"
SET DIC(0)="L"
SET DLAYGO=509850.7
+3 SET ACKLAYGO=""
SET X=ACKMO
SET DINUM=IFN
DO FILE^DICN
+4 QUIT
CRE8DIV ; create a header record for the division
+1 NEW DIC,DINUM,CDR,DD,DO
+2 SET DIC="^ACK(509850.7,"_IFN_",5,"
SET DIC(0)="L"
SET DLAYGO=509850.75
+3 SET DIC("P")=$PIECE(^DD(509850.7,5,0),U,2)
+4 SET ACKLAYGO=""
SET X=ACKDIV
SET DINUM=ACKDIV
SET DA=ACKDIV
SET DA(1)=IFN
DO FILE^DICN
+5 QUIT
README ;Instructional Support (.12) Calculation:
+1 ;As per Dr. Kyle Dennis 5/13/96. First 2 digits of CDR#
+2 ;identify most CDR categories. 11-Medical, 12-Surgical,
+3 ;13-Psych, 14-NH, 15-Dom Care, 16-Inter. Care, 17-Psych Rehab.
+4 ;The CDR to be credited is: First 2 digits_"00.12"
+5 ;CDR range 2110 through 2780 is Outpatient Care 2800.12.
+6 ;If site uses 5100 HBHC, site must add 5100.12 to CDR file.
+7 ;If site uses 8024 DOD SHARE, site must add 8000.12 to CDR file.
+8 ;Ignore CATEGORY 11 and 12 from CDR file (#509850).
