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

ACKQCDD.m

Go to the documentation of this file.
  1. ACKQCDD ;AUG/JLTP BIR/PTD HCIOFO/AG -Generate A&SP Service CDR for a Division; [ 03/03/98 3:10 PM ]
  1. ;;3.0;QUASAR;;Feb 11, 2000
  1. ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
  1. ;
  1. SITE ; check whether the CDR should be run for the site or for each Division
  1. S ACKQCDR=$$GET1^DIQ(509850.8,"1,",.1,"I")
  1. I ACKQCDR'="D" G EXIT ; parameter not set to Division
  1. ;
  1. OPTN ;Introduce option.
  1. W @IOF,!,"This option generates and prints the Audiology and"
  1. W !,"Speech Pathology Service Cost Distribution Report"
  1. W !,"for a single Division.",!
  1. ;
  1. K ^TMP("ACKQCDD",$J)
  1. ;
  1. ; prompt for Division
  1. S ACKDIV=$$DIV^ACKQUTL2(1,.ACKDIVX,"AI")
  1. S ACKDIV=$O(ACKDIVX(""))
  1. ; if no division selected then exit
  1. I +ACKDIV=0 G EXIT
  1. ; ask if data is to be saved
  1. ; returns ACKSAV
  1. D SAVE G:$D(DIRUT) EXIT
  1. ; get the date range
  1. ; returns ACKSD and ACKED and ACKXRNG
  1. D DATES G:$D(DIRUT) EXIT
  1. ;
  1. HRS ; calculate the total clinic hours
  1. D CLINH^ACKQCDD2
  1. ; if no hours found, ask user if they want to proceed.
  1. I '(ACKTCH+ACKTSH),'$$OK G EXIT
  1. ;
  1. ; display total clinic hours and total student hours
  1. W !!,"Total Clinic Hours for ",ACKXRNG,": ",$J((ACKTCH+ACKTSH),0,2)
  1. I ACKTSH D
  1. . W !,"Of that total, ",$J(ACKTSH,0,2)," hours are Instructional Support (.12)."
  1. . W !,"Remaining Clinic Hours: ",$J(ACKTCH,0,2)
  1. ;
  1. ; prompt for total paid hours
  1. D TPH^ACKQCDD2 G:$D(DIRUT) EXIT S ACKRTH=ACKTPH
  1. ;
  1. INPUT ;
  1. ; ask user for flat values for Admin Support and Cont Education
  1. S ACKCATI="E",ACKCAT="ADMIN SUPT (.13) & CONT ED (.14)"
  1. D YNFLAT G:$D(DIRUT) EXIT
  1. I ACKFLAT D FNH G:$D(DIRUT) EXIT
  1. I 'ACKFLAT D G:$D(DIRUT) EXIT
  1. .S ACKIC=0
  1. .F S ACKIC=$O(^ACK(509850,"AT",ACKCATI,ACKIC)) Q:'ACKIC D Q:$D(DIRUT)
  1. ..S ACKCDZ=^ACK(509850,ACKIC,0)
  1. ..I +ACKCDZ'[.12 D INDCAT^ACKQCDD2(ACKIC) Q:$D(DIRUT)
  1. ;
  1. ; ask user for flat values for Research
  1. S ACKCATI="R",ACKCAT="RESEARCH"
  1. D YNFLAT G:$D(DIRUT) EXIT
  1. I ACKFLAT D FNH G:$D(DIRUT) EXIT
  1. I 'ACKFLAT D G:$D(DIRUT) EXIT
  1. .S ACKIC=0
  1. .F S ACKIC=$O(^ACK(509850,"AT",ACKCATI,ACKIC)) Q:'ACKIC D Q:$D(DIRUT)
  1. ..S ACKCDZ=^ACK(509850,ACKIC,0)
  1. ..I +ACKCDZ'[.12 D INDCAT^ACKQCDD2(ACKIC) Q:$D(DIRUT)
  1. ;
  1. PASS ; now do Pass-through accounts
  1. W !!,"Now for pass through CDR accounts..."
  1. ;
  1. ; prompt for each pass-through account until user exits
  1. F D PASS^ACKQCDD2 I $D(DIRUT) K DIRUT Q
  1. ;
  1. ; calculate remaining hours
  1. S ACKRTH=ACKRTH-(ACKTCH+ACKTSH)
  1. ;
  1. ; check there are no remaining hours if there are no clinic hours left
  1. I 'ACKTCH,ACKRTH D G EXIT
  1. . W !!,$C(7),"You have hours remaining but no clinic visits to which they can be"
  1. . W !,"distributed! That won't work...",!!
  1. ;
  1. ; distribute remaining hours
  1. I ACKRTH D DISREM^ACKQCDD2
  1. ; convert values to percentages, index the file
  1. D PERCENT^ACKQCDD2,INDEX^ACKQCDD2
  1. ; if user wants values saved, then save them
  1. D:ACKSAV SAVE^ACKQCDD2
  1. ;
  1. ; print the report
  1. DEV W !!,"The right margin for this report is 80."
  1. W !,"You can queue it to run at a later time.",!
  1. K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS
  1. I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED." G EXIT
  1. ; if queue selected then add job to queue
  1. I $D(IO("Q")) D G EXIT
  1. . K IO("Q")
  1. . S ZTRTN="DQ^ACKQCDD",ZTDESC="QUASAR - Generate A&SP Service CDR"
  1. . S ZTSAVE("ACK*")="",ZTSAVE("^TMP(""ACKQCDD"",$J,")=""
  1. . D ^%ZTLOAD D HOME^%ZIS K ZTSK
  1. ;
  1. DQ ; entry point if queued
  1. U IO
  1. D NOW^%DTC
  1. S ACKPDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%),ACKPG=0
  1. D PRINT^ACKQCDD3
  1. ;
  1. EXIT ; always exit here
  1. K ACK2,ACKCAT,ACKCATI,ACKCDZ,ACKED,ACKFLAT,ACKIC,ACKLAYGO,ACKMO,ACKPDT
  1. K ACKPG,ACKRTH,ACKSAV,ACKSD,ACKTCH,ACKTP,ACKTPH,ACKTSH,ACKXRNG,ACKDIV
  1. K %,%I,%ZIS,CDR,D,D0,DA,DIC,DIE,DI,DIK,DIR,DIRUT,DQ,DR,DTOUT,DUOUT
  1. K HD,I,M,NEWHD,SUB,X,X1,X2,Y,YN,ZTDESC,ZTRTN,ZTSAVE,ZTSK
  1. K ACKQCDR,ACKVDIV,ACKCDRN,DLAYGO,ACKDIVX
  1. K ^TMP("ACKQCDD",$J)
  1. D:$E(IOST)="C" PAUSE^ACKQUTL D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
  1. ; W:$E(IOST)="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
  1. Q
  1. SAVE ;
  1. N DIR,X,Y
  1. SAVE2 K DTOUT,DUOUT,DIRUT,DIR
  1. S DIR(0)="Y",DIR("A")="Save Report Data",DIR("B")="YES"
  1. S DIR("?")="Answer YES or NO.",DIR("??")="^D SAVE^ACKQCDD1"
  1. D ^DIR K DTOUT,DUOUT
  1. I Y?1"^"1.E W !,"Jumping not allowed.",! G SAVE2
  1. S ACKSAV=Y
  1. Q
  1. DATES ;
  1. N DIR,X,Y
  1. I ACKSAV D MONTH Q
  1. DATES2 K DTOUT,DUOUT,DIRUT,DIR
  1. S DIR(0)="SB^M:MONTH;D:DATE RANGE",DIR("B")="M"
  1. S DIR("A")="Generate CDR for a (M)onth or a (D)ate Range"
  1. S DIR("?")="Enter 'M' for MONTH or 'D' for DATE RANGE."
  1. S DIR("??")="^D DATES^ACKQCDD1"
  1. D ^DIR K DIR
  1. I Y?1"^"1.E W !,"Jumping not allowed.",! G DATES2
  1. Q:$D(DIRUT)
  1. I Y="D" D RANGE Q
  1. MONTH S DIR(0)="D^::AEP",DIR("A")="Select Month and Year",DIR("B")=$$LM
  1. S DIR("?")="^D HELP^%DTC",DIR("??")="^D MONTH^ACKQCDD1"
  1. D ^DIR
  1. I Y?1"^"1.E W !,"Jumping not allowed.",! G MONTH
  1. Q:$D(DIRUT)
  1. I '$E(Y,4,5) W !,$C(7),"Month Required!" G MONTH
  1. I Y>DT W !,$C(7),"Can't run for future dates!",! G MONTH
  1. S ACKSD=$E(Y,1,5)_"01",ACKED=$E(Y,1,5)_$$LD(Y),ACKMO=$E(Y,1,5)_"00"
  1. S ACKXRNG=$$XDAT^ACKQUTL(ACKMO)
  1. Q
  1. RANGE ;
  1. S DIR(0)="D^::AEXP",DIR("A")="Select Starting Date"
  1. S DIR("?")="^D HELP^%DTC",DIR("??")="^D STARTD^ACKQCDD1"
  1. D ^DIR K DIR
  1. I Y?1"^"1.E W !,"Jumping not allowed.",! G RANGE
  1. Q:$D(DIRUT)
  1. I Y>DT W !,$C(7),"Can't run for future dates!",! G RANGE
  1. S ACKMO="",ACKSD=Y,ACKXRNG=$$XDAT^ACKQUTL(Y)_" to "
  1. ENDD S DIR(0)="D^::AEXP",DIR("A")="Select Ending Date"
  1. S DIR("?")="^D HELP^%DTC",DIR("??")="^D ENDD^ACKQCDD1"
  1. D ^DIR K DIR
  1. I Y?1"^"1.E W !,"Jumping not allowed.",! G ENDD
  1. Q:$D(DIRUT)
  1. I Y>DT W !,"Can't run for future dates!",! G ENDD
  1. I Y<ACKSD W !,"Can't be before Start Date!",! G ENDD
  1. S ACKED=Y,ACKXRNG=ACKXRNG_$$XDAT^ACKQUTL(Y)
  1. Q
  1. YNFLAT ;
  1. N DIR,X,Y
  1. YNFLAT2 K DTOUT,DUOUT,DIRUT,DIR
  1. S DIR(0)="Y",DIR("B")="NO",DIR("?")="Answer YES or NO."
  1. S DIR("A")="Want to enter flat number of hours for "_ACKCAT
  1. S DIR("??")="^D FLAT^ACKQCDD1"
  1. D ^DIR
  1. I Y?1"^"1.E W !,"Jumping not allowed.",! G YNFLAT2
  1. S ACKFLAT=+Y
  1. Q
  1. FNH ;
  1. N DIR,X,Y
  1. FNH2 K DTOUT,DUOUT,DIRUT
  1. S DIR(0)="N^0:"_ACKRTH,DIR("A")="Enter Hours"
  1. S DIR("?")="^W !!,""Enter the number of hours you wish to spread over all of"",!,""the "",ACKCAT,"" accounts."""
  1. D ^DIR
  1. I Y?1"^"1.E W !,"Jumping not allowed.",! G FNH2
  1. Q:$D(DIRUT)
  1. S ACKRTH=ACKRTH-Y D SPREAD(Y,ACKCATI)
  1. Q
  1. SPREAD(X,Y) ;
  1. N C,I,ACKTMP,ACKCDZ
  1. S (C,I)=0 F S I=$O(^ACK(509850,"AT",Y,I)) Q:'I S ACKCDZ=^ACK(509850,I,0) I +ACKCDZ'[.12 S C=C+1,ACKTMP(+ACKCDZ)=0
  1. S I=0 F S I=$O(ACKTMP(I)) Q:'I S ^TMP("ACKQCDD",$J,"ACKH",I)=X/C
  1. Q
  1. LM() ;RETURN EXTERNAL VALUE OF LAST MONTH
  1. N X
  1. S X(1)=$E(DT,1,3),X(2)=$E(DT,4,5)-1
  1. I 'X(2) S X(2)=12,X(1)=X(1)-1
  1. S X(2)=$$PAD^ACKQUTL(X(2),"R",2,"0") Q $$XDAT^ACKQUTL(X(1)_X(2)_"00")
  1. LD(M) ;RETURN LAST DATE OF MONTH M
  1. N X,Y
  1. S Y=$E(M,1,3)+1700,M=+$E(M,4,5),X="31^28^31^30^31^30^31^31^30^31^30^31"
  1. S:(Y#4=0&(Y#100'=0))!(Y#100=0&(Y#400=0)) $P(X,U,2)=29 Q $P(X,U,M)
  1. OK(YN) ;
  1. N DIR,DUOUT,DTOUT,DIRUT
  1. OK2 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Is that ok"
  1. S DIR("A",1)="There are no clinic hours for the specified date range!"
  1. S DIR("?")="Answer YES to continue with CDR or NO to quit."
  1. D ^DIR
  1. I Y?1"^"1.E W !,"Jumping not allowed.",! G OK2
  1. S:$D(DIRUT) Y=0
  1. Q Y