ACKQDWLU ;AUG/JLTP BIR/PTD HCIOFO/BH-QUASAR Utility Routine ; [ 04/25/96 10:03 ]
;;3.0;QUASAR;**1**;Feb 11, 2000
;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
;
WLSTATUS(ACKDA,ACKDIV,ACKWLMSG) ; determine the status for each division
; input : ACKDA=identifier of month to be compiled
;
; array ACKDIV passed by reference (.ACKDIV) containing
; the divisions selected for compilation
; array ACKWLMSG passed by reference (.ACKWLMSG)
; output : ACKWLMSG=status^oktocontinue^message
; and ACKWLMSG(DIV)=null
; where status=0, 1, 2 or 3 (for information only)
; oktocontinue=true, false or unknown (1, 0 or '?')
; message=text message for user
; DIV=list of Divisions the message applies to
; [ ACKWLMSG(DIV) corresponds to ACKDIV(DIV) ]
N DIVNUM,DIVIEN,DIVMSG
K ACKWLMSG
;
; the following section checks each division to determine the worst
; case. it builds the array ACKWLMSG in the following way
; ACKWLMSG=0^0^message - error, do not proceed.
; ACKWLMSG=1^0^msg,ACKWLMSG(DIV)=null - if one or more
; divisions are currently compiling or have been verified.
; ACKWLMSG=2^?^msg,ACKWLMSG(DIV)=null - if no divisions are
; compiling and none have been verified, but one or more have been
; compiled.
; ACKWLMSG=3^1^msg - no division have been compiled, ok to continue
S ACKWLMSG=5,DIVNUM=""
F S DIVNUM=$O(ACKDIV(DIVNUM)) Q:DIVNUM="" D
. S DIVIEN=$P(ACKDIV(DIVNUM),U,1) ; get division IEN
. S DIVMSG=$$WLSTADIV(ACKDA,DIVIEN) ; determine status of this division
. ; if this division is no worse than the current status then ignore
. I +DIVMSG>ACKWLMSG Q
. ; if this division is same as curr status then add to array
. I +ACKWLMSG=+DIVMSG S:+ACKWLMSG<3 ACKWLMSG(DIVNUM)="" Q
. ; if this division is worse than curr status then refresh array
. K ACKWLMSG S ACKWLMSG=DIVMSG S:+ACKWLMSG<3 ACKWLMSG(DIVNUM)=""
. ;
Q ACKWLMSG
;
WLSTADIV(ACKDA,DIVIEN) ; determine status of ACKDIV for month ACKDA
N MSG
I '$D(^ACK(509850.7,ACKDA,5,DIVIEN,0)) D Q MSG
. S MSG="3^1^Capitation Report Not Generated"
I $P(^ACK(509850.7,ACKDA,5,DIVIEN,0),U,8) D Q MSG
. S MSG="1^0^Capitation Report Already Verified"
I $P(^ACK(509850.7,ACKDA,5,DIVIEN,0),U,4) D Q MSG
. S MSG="2^?^Capitation Report Already Generated"
I $P(^ACK(509850.7,ACKDA,5,DIVIEN,0),U,2) D Q MSG
. S MSG="1^0^Capitation Report Already Running - Not Completed"
Q "4^1^Capitation report Cleared down"
;
STAQES(ACKWLMSG) ; Non Interactive run in the background
; input: ACKWLMSG as created in $$WLSTATUS above
; output: 1 if ok to continue, 0 if not
;
; If user not allowed to continue then exit
I $P(ACKWLMSG,U,2)=0 Q 0
; Report not generated - set up record and continue
I $P(ACKWLMSG,U,1)=3,$P(ACKWLMSG,U,2)=1 Q 2
; Data deleted from file - Okay to go
I $P(ACKWLMSG,U,1)=4,$P(ACKWLMSG,U,2)=1 Q 1
; Remaining option is a query - Already been run so quit
I $P(ACKWLMSG,U,2)="?" Q 0
Q
;
;
STAQES1(ACKDA,ACKDIV,ACKWLMSG) ; Interactive Version run in the foreground
;
; Input=ACKDA - Site ID and run date selected
; ACKDIV - Cretated in ^ACKQDWL
; ACKWLMSG - Created in WLSTATUS (above)
;
N ACKX,DIR,Y,DIRUT,DUOUT,DTOUT,ACKDIVNO
; Display message and associated Divisions
; If status is okay quit passing back 1
I $P(ACKWLMSG,U,2)=1 Q 1
; If user is not aloud to continue display problem and quit with "0"
I $P(ACKWLMSG,U,2)=0 D DISPLAY Q 0
;
; Remaining option is a query i.e. $P(ACKWLMSG,U,2)="?"
;
S ACKDIVNO="" W !
W $P(ACKWLMSG,U,3)_" for the following Division(s) ",!!
F S ACKDIVNO=$O(ACKWLMSG(ACKDIVNO)) Q:ACKDIVNO="" D
. W ?54,$P(ACKDIV(ACKDIVNO),U,3),!
;
S DIWL=1,DIWR=80,DIWF=""
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Continue",DIR("A",1)=$P(ACKWLMSG,U,3)
S DIR("?")="Answer Y for YES or N for NO."
S DIR("??")="^W !?5,""If you answer YES, I will re-generate capitation"
S DIR("??")=DIR("??")_" data. This will"",!?5,""overwrite existing "
S DIR("??")=DIR("??")_"capitation data for the chosen month."""
D ^DIR
S X=Y
; If user has entered YES clean up files also check that all Division
; levels have been created if no set them up
I X D CLEAN
Q X
;
;
DISPLAY ; Display Divisions that have problems
;
; Called from STAQES1
;
S ACKDIVNO="" W !!
W $P(ACKWLMSG,U,3),!!
W "This error has been found for the following Division(s) ",!!
F S ACKDIVNO=$O(ACKWLMSG(ACKDIVNO)) Q:ACKDIVNO="" D
. W ?44,$P(ACKDIV(ACKDIVNO),U,3),!
Q
;
CLEAN ; Clean out previously generated data for selected divisions
;
; Called from STAQES1
;
N X,DIVIEN,ACK1
S ACK1=""
D WAIT^DICD
F S ACK1=$O(ACKDIV(ACK1)) Q:ACK1="" D
. S DIVIEN=$P(ACKDIV(ACK1),U,1)
. I '$D(^ACK(509850.7,ACKDA,5,DIVIEN)) D CREATE1 Q
. D STF
. F X=1,2,3,5 D MDL(X,DIVIEN,ACKDA)
Q
;
CREATE(ACKDA,ACKM,ACKDIV) ; Create new date level entry on the workload file
;
; Called from ^ACKQDWL
; Input=ACKDA - Site ID and run date selected
; ACKM - Date run selected in Fm format with '00' for day.
; ACKDIV - Array of Divisions created in ^ACKQDWL
;
I '$D(^ACK(509850.7,ACKDA,0)) D
. S DIC="^ACK(509850.7,",DIC(0)="L",DLAYGO=509850.7,ACKLAYGO=""
. S X=ACKM,DINUM=ACKDA
. D FILE^DICN
;
; If they dont exisit create new Division levels in the Workload file
N DIVIEN,ACK1,X
S ACK1=""
F S ACK1=$O(ACKDIV(ACK1)) Q:ACK1="" D
. S DIVIEN=$P(ACKDIV(ACK1),U,1)
. I $D(^ACK(509850.7,ACKDA,5,DIVIEN)) Q
. D CREATE1
Q
;
CREATE1 ; Called from CLEAN code block
S DIC="^ACK(509850.7,"_ACKDA_",5,"
S DIC(0)="L",DIC("P")="509850.75P"
S DA=DIVIEN,DA(1)=ACKDA,X=DIVIEN,DINUM=DIVIEN
K DD,DO D FILE^DICN
Q
;
STF ; Delete the Start and end time and Job number from record.
; Called from CLEAN code block.
N ACKX,DIE,DR,DA,SL,X,ACKARR
S ACKARR(509850.75,DIVIEN_","_ACKDA_",",5.02)="@"
S ACKARR(509850.75,DIVIEN_","_ACKDA_",",5.03)="@"
S ACKARR(509850.75,DIVIEN_","_ACKDA_",",5.04)="@"
D FILE^DIE("K","ACKARR")
Q
;
MDL(FLD,DIVIEN,ACKDA) ; Delete all entries from Multiple
; Called from CLEAN code block.
; Input=FLD - Multiple field level being deleted (1,2 or 3)
; DIVIEN - Division IEN #
; ACKDA - Site ID and run date selected
;
N ACKARR,ACKSUB
S ACKSUB="0"
F S ACKSUB=$O(^ACK(509850.7,ACKDA,5,DIVIEN,FLD,ACKSUB)) Q:'ACKSUB!(ACKSUB'?.N) D
. I FLD=1 S ACKARR(509850.751,ACKSUB_","_DIVIEN_","_ACKDA_",",.01)="@"
. I FLD=2 S ACKARR(509850.752,ACKSUB_","_DIVIEN_","_ACKDA_",",.01)="@"
. I FLD=3 S ACKARR(509850.753,ACKSUB_","_DIVIEN_","_ACKDA_",",.01)="@"
. I FLD=5 S ACKARR(509850.755,ACKSUB_","_DIVIEN_","_ACKDA_",",.01)="@"
I $D(ACKARR) D FILE^DIE("K","ACKARR")
Q
;
ECSTAT ; For EC Stats.
;
N ACKCODE
S ACK6=0
F S ACK6=$O(^ACK(509850.7,ACKDA,5,ACKVDVN,5,ACK6)) Q:ACK6=""!(ACK6'?.N) D
. S ACKREC=^ACK(509850.7,ACKDA,5,ACKVDVN,5,ACK6,0)
. S ACKAUD=$P(ACKREC,U,2,4),ACKSPE=$P(ACKREC,U,5,7)
. S ACKCODE=$P(ACKREC,U,1)
. I $TR(ACKAUD,"^","")'="" D
. . S ^TMP("ACKQDWLP",$J,"R",ACKVDVN,5,"A",ACKCODE)=ACKAUD
. . S ^TMP("ACKQDWLP",$J,"S",5,"A",ACKCODE,ACKVDVN)=ACKAUD
. I $TR(ACKSPE,"^","")'="" D
. . S ^TMP("ACKQDWLP",$J,"R",ACKVDVN,5,"S",ACKCODE)=ACKSPE
. . S ^TMP("ACKQDWLP",$J,"S",5,"S",ACKCODE,ACKVDVN)=ACKSPE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQDWLU 7482 printed Apr 09, 2024@21:34:50 Page 2
ACKQDWLU ;AUG/JLTP BIR/PTD HCIOFO/BH-QUASAR Utility Routine ; [ 04/25/96 10:03 ]
+1 ;;3.0;QUASAR;**1**;Feb 11, 2000
+2 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
+3 ;
WLSTATUS(ACKDA,ACKDIV,ACKWLMSG) ; determine the status for each division
+1 ; input : ACKDA=identifier of month to be compiled
+2 ;
+3 ; array ACKDIV passed by reference (.ACKDIV) containing
+4 ; the divisions selected for compilation
+5 ; array ACKWLMSG passed by reference (.ACKWLMSG)
+6 ; output : ACKWLMSG=status^oktocontinue^message
+7 ; and ACKWLMSG(DIV)=null
+8 ; where status=0, 1, 2 or 3 (for information only)
+9 ; oktocontinue=true, false or unknown (1, 0 or '?')
+10 ; message=text message for user
+11 ; DIV=list of Divisions the message applies to
+12 ; [ ACKWLMSG(DIV) corresponds to ACKDIV(DIV) ]
+13 NEW DIVNUM,DIVIEN,DIVMSG
+14 KILL ACKWLMSG
+15 ;
+16 ; the following section checks each division to determine the worst
+17 ; case. it builds the array ACKWLMSG in the following way
+18 ; ACKWLMSG=0^0^message - error, do not proceed.
+19 ; ACKWLMSG=1^0^msg,ACKWLMSG(DIV)=null - if one or more
+20 ; divisions are currently compiling or have been verified.
+21 ; ACKWLMSG=2^?^msg,ACKWLMSG(DIV)=null - if no divisions are
+22 ; compiling and none have been verified, but one or more have been
+23 ; compiled.
+24 ; ACKWLMSG=3^1^msg - no division have been compiled, ok to continue
+25 SET ACKWLMSG=5
SET DIVNUM=""
+26 FOR
SET DIVNUM=$ORDER(ACKDIV(DIVNUM))
if DIVNUM=""
QUIT
Begin DoDot:1
+27 ; get division IEN
SET DIVIEN=$PIECE(ACKDIV(DIVNUM),U,1)
+28 ; determine status of this division
SET DIVMSG=$$WLSTADIV(ACKDA,DIVIEN)
+29 ; if this division is no worse than the current status then ignore
+30 IF +DIVMSG>ACKWLMSG
QUIT
+31 ; if this division is same as curr status then add to array
+32 IF +ACKWLMSG=+DIVMSG
if +ACKWLMSG<3
SET ACKWLMSG(DIVNUM)=""
QUIT
+33 ; if this division is worse than curr status then refresh array
+34 KILL ACKWLMSG
SET ACKWLMSG=DIVMSG
if +ACKWLMSG<3
SET ACKWLMSG(DIVNUM)=""
+35 ;
End DoDot:1
+36 QUIT ACKWLMSG
+37 ;
WLSTADIV(ACKDA,DIVIEN) ; determine status of ACKDIV for month ACKDA
+1 NEW MSG
+2 IF '$DATA(^ACK(509850.7,ACKDA,5,DIVIEN,0))
Begin DoDot:1
+3 SET MSG="3^1^Capitation Report Not Generated"
End DoDot:1
QUIT MSG
+4 IF $PIECE(^ACK(509850.7,ACKDA,5,DIVIEN,0),U,8)
Begin DoDot:1
+5 SET MSG="1^0^Capitation Report Already Verified"
End DoDot:1
QUIT MSG
+6 IF $PIECE(^ACK(509850.7,ACKDA,5,DIVIEN,0),U,4)
Begin DoDot:1
+7 SET MSG="2^?^Capitation Report Already Generated"
End DoDot:1
QUIT MSG
+8 IF $PIECE(^ACK(509850.7,ACKDA,5,DIVIEN,0),U,2)
Begin DoDot:1
+9 SET MSG="1^0^Capitation Report Already Running - Not Completed"
End DoDot:1
QUIT MSG
+10 QUIT "4^1^Capitation report Cleared down"
+11 ;
STAQES(ACKWLMSG) ; Non Interactive run in the background
+1 ; input: ACKWLMSG as created in $$WLSTATUS above
+2 ; output: 1 if ok to continue, 0 if not
+3 ;
+4 ; If user not allowed to continue then exit
+5 IF $PIECE(ACKWLMSG,U,2)=0
QUIT 0
+6 ; Report not generated - set up record and continue
+7 IF $PIECE(ACKWLMSG,U,1)=3
IF $PIECE(ACKWLMSG,U,2)=1
QUIT 2
+8 ; Data deleted from file - Okay to go
+9 IF $PIECE(ACKWLMSG,U,1)=4
IF $PIECE(ACKWLMSG,U,2)=1
QUIT 1
+10 ; Remaining option is a query - Already been run so quit
+11 IF $PIECE(ACKWLMSG,U,2)="?"
QUIT 0
+12 QUIT
+13 ;
+14 ;
STAQES1(ACKDA,ACKDIV,ACKWLMSG) ; Interactive Version run in the foreground
+1 ;
+2 ; Input=ACKDA - Site ID and run date selected
+3 ; ACKDIV - Cretated in ^ACKQDWL
+4 ; ACKWLMSG - Created in WLSTATUS (above)
+5 ;
+6 NEW ACKX,DIR,Y,DIRUT,DUOUT,DTOUT,ACKDIVNO
+7 ; Display message and associated Divisions
+8 ; If status is okay quit passing back 1
+9 IF $PIECE(ACKWLMSG,U,2)=1
QUIT 1
+10 ; If user is not aloud to continue display problem and quit with "0"
+11 IF $PIECE(ACKWLMSG,U,2)=0
DO DISPLAY
QUIT 0
+12 ;
+13 ; Remaining option is a query i.e. $P(ACKWLMSG,U,2)="?"
+14 ;
+15 SET ACKDIVNO=""
WRITE !
+16 WRITE $PIECE(ACKWLMSG,U,3)_" for the following Division(s) ",!!
+17 FOR
SET ACKDIVNO=$ORDER(ACKWLMSG(ACKDIVNO))
if ACKDIVNO=""
QUIT
Begin DoDot:1
+18 WRITE ?54,$PIECE(ACKDIV(ACKDIVNO),U,3),!
End DoDot:1
+19 ;
+20 SET DIWL=1
SET DIWR=80
SET DIWF=""
+21 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Continue"
SET DIR("A",1)=$PIECE(ACKWLMSG,U,3)
+22 SET DIR("?")="Answer Y for YES or N for NO."
+23 SET DIR("??")="^W !?5,""If you answer YES, I will re-generate capitation"
+24 SET DIR("??")=DIR("??")_" data. This will"",!?5,""overwrite existing "
+25 SET DIR("??")=DIR("??")_"capitation data for the chosen month."""
+26 DO ^DIR
+27 SET X=Y
+28 ; If user has entered YES clean up files also check that all Division
+29 ; levels have been created if no set them up
+30 IF X
DO CLEAN
+31 QUIT X
+32 ;
+33 ;
DISPLAY ; Display Divisions that have problems
+1 ;
+2 ; Called from STAQES1
+3 ;
+4 SET ACKDIVNO=""
WRITE !!
+5 WRITE $PIECE(ACKWLMSG,U,3),!!
+6 WRITE "This error has been found for the following Division(s) ",!!
+7 FOR
SET ACKDIVNO=$ORDER(ACKWLMSG(ACKDIVNO))
if ACKDIVNO=""
QUIT
Begin DoDot:1
+8 WRITE ?44,$PIECE(ACKDIV(ACKDIVNO),U,3),!
End DoDot:1
+9 QUIT
+10 ;
CLEAN ; Clean out previously generated data for selected divisions
+1 ;
+2 ; Called from STAQES1
+3 ;
+4 NEW X,DIVIEN,ACK1
+5 SET ACK1=""
+6 DO WAIT^DICD
+7 FOR
SET ACK1=$ORDER(ACKDIV(ACK1))
if ACK1=""
QUIT
Begin DoDot:1
+8 SET DIVIEN=$PIECE(ACKDIV(ACK1),U,1)
+9 IF '$DATA(^ACK(509850.7,ACKDA,5,DIVIEN))
DO CREATE1
QUIT
+10 DO STF
+11 FOR X=1,2,3,5
DO MDL(X,DIVIEN,ACKDA)
End DoDot:1
+12 QUIT
+13 ;
CREATE(ACKDA,ACKM,ACKDIV) ; Create new date level entry on the workload file
+1 ;
+2 ; Called from ^ACKQDWL
+3 ; Input=ACKDA - Site ID and run date selected
+4 ; ACKM - Date run selected in Fm format with '00' for day.
+5 ; ACKDIV - Array of Divisions created in ^ACKQDWL
+6 ;
+7 IF '$DATA(^ACK(509850.7,ACKDA,0))
Begin DoDot:1
+8 SET DIC="^ACK(509850.7,"
SET DIC(0)="L"
SET DLAYGO=509850.7
SET ACKLAYGO=""
+9 SET X=ACKM
SET DINUM=ACKDA
+10 DO FILE^DICN
End DoDot:1
+11 ;
+12 ; If they dont exisit create new Division levels in the Workload file
+13 NEW DIVIEN,ACK1,X
+14 SET ACK1=""
+15 FOR
SET ACK1=$ORDER(ACKDIV(ACK1))
if ACK1=""
QUIT
Begin DoDot:1
+16 SET DIVIEN=$PIECE(ACKDIV(ACK1),U,1)
+17 IF $DATA(^ACK(509850.7,ACKDA,5,DIVIEN))
QUIT
+18 DO CREATE1
End DoDot:1
+19 QUIT
+20 ;
CREATE1 ; Called from CLEAN code block
+1 SET DIC="^ACK(509850.7,"_ACKDA_",5,"
+2 SET DIC(0)="L"
SET DIC("P")="509850.75P"
+3 SET DA=DIVIEN
SET DA(1)=ACKDA
SET X=DIVIEN
SET DINUM=DIVIEN
+4 KILL DD,DO
DO FILE^DICN
+5 QUIT
+6 ;
STF ; Delete the Start and end time and Job number from record.
+1 ; Called from CLEAN code block.
+2 NEW ACKX,DIE,DR,DA,SL,X,ACKARR
+3 SET ACKARR(509850.75,DIVIEN_","_ACKDA_",",5.02)="@"
+4 SET ACKARR(509850.75,DIVIEN_","_ACKDA_",",5.03)="@"
+5 SET ACKARR(509850.75,DIVIEN_","_ACKDA_",",5.04)="@"
+6 DO FILE^DIE("K","ACKARR")
+7 QUIT
+8 ;
MDL(FLD,DIVIEN,ACKDA) ; Delete all entries from Multiple
+1 ; Called from CLEAN code block.
+2 ; Input=FLD - Multiple field level being deleted (1,2 or 3)
+3 ; DIVIEN - Division IEN #
+4 ; ACKDA - Site ID and run date selected
+5 ;
+6 NEW ACKARR,ACKSUB
+7 SET ACKSUB="0"
+8 FOR
SET ACKSUB=$ORDER(^ACK(509850.7,ACKDA,5,DIVIEN,FLD,ACKSUB))
if 'ACKSUB!(ACKSUB'?.N)
QUIT
Begin DoDot:1
+9 IF FLD=1
SET ACKARR(509850.751,ACKSUB_","_DIVIEN_","_ACKDA_",",.01)="@"
+10 IF FLD=2
SET ACKARR(509850.752,ACKSUB_","_DIVIEN_","_ACKDA_",",.01)="@"
+11 IF FLD=3
SET ACKARR(509850.753,ACKSUB_","_DIVIEN_","_ACKDA_",",.01)="@"
+12 IF FLD=5
SET ACKARR(509850.755,ACKSUB_","_DIVIEN_","_ACKDA_",",.01)="@"
End DoDot:1
+13 IF $DATA(ACKARR)
DO FILE^DIE("K","ACKARR")
+14 QUIT
+15 ;
ECSTAT ; For EC Stats.
+1 ;
+2 NEW ACKCODE
+3 SET ACK6=0
+4 FOR
SET ACK6=$ORDER(^ACK(509850.7,ACKDA,5,ACKVDVN,5,ACK6))
if ACK6=""!(ACK6'?.N)
QUIT
Begin DoDot:1
+5 SET ACKREC=^ACK(509850.7,ACKDA,5,ACKVDVN,5,ACK6,0)
+6 SET ACKAUD=$PIECE(ACKREC,U,2,4)
SET ACKSPE=$PIECE(ACKREC,U,5,7)
+7 SET ACKCODE=$PIECE(ACKREC,U,1)
+8 IF $TRANSLATE(ACKAUD,"^","")'=""
Begin DoDot:2
+9 SET ^TMP("ACKQDWLP",$JOB,"R",ACKVDVN,5,"A",ACKCODE)=ACKAUD
+10 SET ^TMP("ACKQDWLP",$JOB,"S",5,"A",ACKCODE,ACKVDVN)=ACKAUD
End DoDot:2
+11 IF $TRANSLATE(ACKSPE,"^","")'=""
Begin DoDot:2
+12 SET ^TMP("ACKQDWLP",$JOB,"R",ACKVDVN,5,"S",ACKCODE)=ACKSPE
+13 SET ^TMP("ACKQDWLP",$JOB,"S",5,"S",ACKCODE,ACKVDVN)=ACKSPE
End DoDot:2
End DoDot:1
+14 QUIT
