Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACKQCDD2

ACKQCDD2.m

Go to the documentation of this file. 
  1. 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
  1.  ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
  1. INDCAT(ACKCDR) ;Enter hours for CDR account.
  1.  N DIR,Y,CDR,X
  1. INDCAT2 K DIRUT,DUOUT,DTOUT,DIR S X=ACKCDR
  1.  S DIR(0)="N^0:"_ACKRTH,CDR=$P(^ACK(509850,X,0),U)_" "_$P(^(0),U,2)
  1.  S DIR("A")="Enter Hours for "_CDR
  1.  S DIR("??")="^W !!,""Enter the number of hours that you wish to charge to CDR"",!,""account "",CDR,""."""
  1.  D ^DIR
  1.  I Y?1"^"1.E W !,"Jumping not allowed.",! G INDCAT2
  1.  Q:$D(DIRUT)
  1.  S ^TMP("ACKQCDD",$J,"ACKH",+CDR)=Y,ACKRTH=ACKRTH-Y
  1.  Q
  1. PASS ;Enter hours for pass-through account.
  1.  N DIC,DIR,X,Y,CDR
  1. PASS2 S DIC="^ACK(509850,",DIC("A")="Select Pass-Through Account: "
  1.  S DIC("S")="I $P(^(0),U,3)=""P""",DIC(0)="AEMQZ"
  1.  D ^DIC K DIC
  1.  I X?1"^"1.E W !,"Jumping not allowed.",! G PASS2
  1.  I Y<0 S DIRUT=1 Q
  1.  S CDR=+$P(Y,U,2),CDR(0)=$P(Y(0),U,2)
  1. PASS3 I $D(^TMP("ACKQCDD",$J,"ACKH",CDR)) S DIR("B")=^TMP("ACKQCDD",$J,"ACKH",CDR)
  1.  S DIR(0)="N^0:"_ACKRTH,DIR("A")="Enter Hours for "_CDR(0)
  1.  S DIR("??")="^W !!,""Enter the number of hours to charge to "",CDR(0)"
  1.  D ^DIR
  1.  I Y?1"^"1.E W !,"Jumping not allowed.",! G PASS3
  1.  Q:$D(DIRUT)
  1.  S ^TMP("ACKQCDD",$J,"ACKH",CDR)=Y S:$D(DIR("B")) ACKRTH=ACKRTH+DIR("B") S ACKRTH=ACKRTH-Y
  1.  Q
  1. DISREM ;DISTRIBUTE REMAINING HOURS
  1.  N I,X
  1.  S I=0 F  S I=$O(ACKTCH(I)) Q:'I  D
  1.  .S X=(ACKTCH(I)/ACKTCH)*ACKRTH,ACKTCH(I)=ACKTCH(I)+X
  1.  Q
  1. PERCENT ;CONVERT ALL VALUES TO %
  1.  N I,X
  1.  S ACKTP=0
  1.  S I=0 F  S I=$O(^TMP("ACKQCDD",$J,"ACKH",I)) Q:'I  D
  1.  . S X=^TMP("ACKQCDD",$J,"ACKH",I)/ACKTPH*100
  1.  . S ^TMP("ACKQCDD",$J,"ACKH",I)=X,ACKTP=ACKTP+X
  1.  S I=0 F  S I=$O(ACKTCH(I)) Q:'I  D
  1.  . S ^TMP("ACKQCDD",$J,"ACKH",I)=ACKTCH(I)/ACKTPH*100
  1.  . S ACKTP=ACKTP+^TMP("ACKQCDD",$J,"ACKH",I)
  1.  K ACKTCH
  1.  Q
  1.  ;
  1. CLINH ;Calculate number of clinic hours & student training 
  1.  ;   (.12) by CDR series. See README at end.
  1.  ;  requires ACKSD - start of date range
  1.  ;           ACKED - end of date range
  1.  ;           ACKDIV - selected division
  1.  N ACKCDR,ACKD,I,ACKV,ACKMINS
  1.  K ACKTCH,ACKTSH S (ACKTCH,ACKTSH)=0
  1.  ;Loop through selected date range and get total minutes and total
  1.  ; student minutes
  1.  F ACKD=(ACKSD-.1):0 S ACKD=$O(^ACK(509850.6,"B",ACKD)) Q:'ACKD!(ACKD>(ACKED+.9))  D
  1.  .S ACKV=0 F  S ACKV=$O(^ACK(509850.6,"B",ACKD,ACKV)) Q:'ACKV  D
  1.  .. ; check division
  1.  .. S ACKVDIV=$$GET1^DIQ(509850.6,ACKV_",",60,"I")
  1.  .. I ACKVDIV'=ACKDIV Q
  1.  ..;Get TIME SPENT and CDR#. Student present? YES, increment ACKTSH array; else increment ACKTCH array.
  1.  ..S ACKMINS=+$P(^ACK(509850.6,ACKV,0),U,7)
  1.  ..S ACK2=^ACK(509850.6,ACKV,2)
  1.  ..S ACKCDR=+$P(ACK2,U,2),ACKCDRN=+$P($G(^ACK(509850,ACKCDR,0)),U,1)
  1.  ..I $P(ACK2,U,4) D  ;student present
  1.  ...S ACKTSH=ACKTSH+ACKMINS
  1.  ...S ACKTSH($E(ACKCDRN,1,2))=$G(ACKTSH($E(ACKCDRN,1,2)))+ACKMINS
  1.  ..I '$P(ACK2,U,4) D  ;student not present
  1.  ...S ACKTCH=ACKTCH+ACKMINS
  1.  ...S ACKTCH(ACKCDRN)=$G(ACKTCH(ACKCDRN))+ACKMINS
  1.  ;
  1.  ;Convert minutes to hours - total time (less student)
  1.  S ACKTCH=ACKTCH/60
  1.  S ACKCDRN=0 F  S ACKCDRN=$O(ACKTCH(ACKCDRN)) Q:'ACKCDRN  D
  1.  . S ACKTCH(ACKCDRN)=ACKTCH(ACKCDRN)/60
  1.  ;Convert minutes to hours - student time, and move into ^TMP
  1.  S ACKTSH=ACKTSH/60
  1.  S ACKCDRN=0 F  S ACKCDRN=$O(ACKTSH(ACKCDRN)) Q:'ACKCDRN  D
  1.  . S ACKTSH(ACKCDRN)=ACKTSH(ACKCDRN)/60
  1.  . I (ACKCDRN<21)!(ACKCDRN>27) D
  1.  .. S ^TMP("ACKQCDD",$J,"ACKH",ACKCDRN_"00.12")=+ACKTSH(ACKCDRN)
  1.  . I ACKCDRN'<21,ACKCDRN'>27 D
  1.  .. S ^TMP("ACKQCDD",$J,"ACKH",2800.12)=+ACKTSH(ACKCDRN)
  1.  Q
  1.  ;
  1. TPH ;Ask for Total Paid Hours.
  1.  N DIR,X,Y
  1. TPH2 K DTOUT,DUOUT,DIRUT,DIR
  1.  S DIR(0)="N^1:9999",DIR("A")="Enter Total Paid Hours"
  1.  S DIR("?")="Enter a number between 1 and 9999."
  1.  S DIR("??")="^D TPH^ACKQCDD1"
  1.  W ! D ^DIR
  1.  I Y?1"^"1.E W !,"Jumping not allowed.",! G TPH2
  1.  S ACKTPH=+Y
  1.  Q
  1. INDEX ;Build ^TMP arrays in category and CDR# order.
  1.  N I,CAT,CDR
  1.  S I=0 F  S I=$O(^ACK(509850,I)) Q:'I  D
  1.  . S CDR=^ACK(509850,I,0),CAT=$P(CDR,U,4)
  1.  . S ^TMP("ACKQCDD",$J,"ACKCAT",CAT,+CDR)=$P(CDR,U,1,2)
  1.  . S:ACKSAV ^TMP("ACKQCDD",$J,"ACKNDX",+CDR)=$P(CDR,U)
  1.  Q
  1. SAVE ;
  1.  N IFN,M
  1.  S IFN=+$$SITE^VASITE_$E(ACKMO,1,5)
  1.  ;
  1.  ; if there is data for the selected month/division then ask to delete
  1.  I $O(^ACK(509850.7,IFN,5,ACKDIV,4,0)) D  Q:$D(DIRUT)
  1.  .K DIR,X,Y S DIR(0)="Y",DIR("A")="Delete existing CDR data and regenerate the CDR for "_ACKXRNG,DIR("B")="NO"
  1.  .S DIR("?")="Enter YES to delete and regenerate the CDR, otherwise enter NO.",DIR("??")="^D REGEN^ACKQHLP1"
  1.  .W ! D ^DIR K DIR S:Y=0 DIRUT=1 Q:$D(DIRUT)
  1.  .D KILLOLD ;remove old data for this month and division
  1.  ;
  1.  ; now (re)create the file
  1.  L +^ACK(509850.7,IFN)
  1.  ; check the headers exist
  1.  I '$D(^ACK(509850.7,IFN,0)) D CRE8HDR
  1.  I '$D(^ACK(509850.7,IFN,5,ACKDIV,0)) D CRE8DIV
  1.  ;
  1.  ; file the CDR total paid hours
  1.  S DIE="^ACK(509850.7,"_IFN_",5,",DA=ACKDIV,DA(1)=IFN,DR="5.05////"_ACKTPH D ^DIE K DIE,DA,DR
  1.  ;
  1.  ; update CDR percentages
  1.  S CDR=0 F  S CDR=$O(^TMP("ACKQCDD",$J,"ACKH",CDR)) Q:'CDR  I ^TMP("ACKQCDD",$J,"ACKH",CDR) D
  1.  .S DIC="^ACK(509850.7,"_IFN_",5,"_ACKDIV_",4,",DIC(0)="L"
  1.  .S DLAYGO=509850.75,X=$P(^TMP("ACKQCDD",$J,"ACKNDX",CDR),U),DINUM=+X
  1.  .S DIC("P")=$P(^DD(509850.75,5.8,0),U,2),DA(2)=IFN,DA(1)=ACKDIV
  1.  .K DD,DO D FILE^DICN K DA
  1.  .S DIE="^ACK(509850.7,"_IFN_",5,"_ACKDIV_",4,"
  1.  .S DA=+CDR,DA(1)=ACKDIV,DA(2)=IFN
  1.  .S DR="54.02////"_$J(^TMP("ACKQCDD",$J,"ACKH",+CDR),0,9)
  1.  .D ^DIE
  1.  ;
  1.  ; end
  1.  L -^ACK(509850.7,IFN)
  1.  Q
  1. KILLOLD ;kill existing CDR data for the selected month and division
  1.  S DIK="^ACK(509850.7,"_IFN_",5,"_ACKDIV_",4,",DA(2)=IFN,DA(1)=ACKDIV
  1.  ; loop for each CDR and kill
  1.  S SUB=0
  1.  F  S SUB=$O(^ACK(509850.7,IFN,5,ACKDIV,4,SUB)) Q:'SUB  S DA=SUB D ^DIK
  1.  ; remove the CDR total paid hours field
  1.  S DIE="^ACK(509850.7,"_IFN_",5,",DA=ACKDIV,DA(1)=IFN
  1.  S DR="5.02///"_"@" D ^DIE K DIE,DA,DR
  1.  ; if there is no workload for the division for the month then empty the file completely
  1.  I '$O(^ACK(509850.7,IFN,5,ACKDIV,1,0)) D
  1.  . S DIK="^ACK(509850.7,"_IFN_",5,",DA=ACKDIV,DA(1)=IFN D ^DIK
  1.  ; end
  1.  Q
  1. CRE8HDR ; create a header record for the month
  1.  N DIC,DINUM,CDR,DD,DO
  1.  S DIC="^ACK(509850.7,",DIC(0)="L",DLAYGO=509850.7
  1.  S ACKLAYGO="",X=ACKMO,DINUM=IFN D FILE^DICN
  1.  Q
  1. CRE8DIV ; create a header record for the division
  1.  N DIC,DINUM,CDR,DD,DO
  1.  S DIC="^ACK(509850.7,"_IFN_",5,",DIC(0)="L",DLAYGO=509850.75
  1.  S DIC("P")=$P(^DD(509850.7,5,0),U,2)
  1.  S ACKLAYGO="",X=ACKDIV,DINUM=ACKDIV,DA=ACKDIV,DA(1)=IFN D FILE^DICN
  1.  Q
  1. README ;Instructional Support (.12) Calculation:
  1.  ;As per Dr. Kyle Dennis 5/13/96. First 2 digits of CDR#
  1.  ;identify most CDR categories. 11-Medical, 12-Surgical,
  1.  ;13-Psych, 14-NH, 15-Dom Care, 16-Inter. Care, 17-Psych Rehab.
  1.  ;The CDR to be credited is: First 2 digits_"00.12"
  1.  ;CDR range 2110 through 2780 is Outpatient Care 2800.12.
  1.  ;If site uses 5100 HBHC, site must add 5100.12 to CDR file.
  1.  ;If site uses 8024 DOD SHARE, site must add 8000.12 to CDR file.
  1.  ;Ignore CATEGORY 11 and 12 from CDR file (#509850).