- ACKQCPL ;AUG/JLTP BIR/PTD HCIOFO/BH-Lookup for C&P Exams Awaiting Adequation ; 04/22/96 14:16
- ;;3.0;QUASAR;;Feb 11, 2000
- ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
- ;
- BUILD ; Build array of exams user can adequate in ^TMP(.
- N ACK5,ACKSTN,ACKDIV,ACKSTAT,ACKDUZ
- S ACKDUZ=$$PROVCHK^ACKQASU4(DUZ) S:ACKDUZ="" ACKDUZ=" "
- S ACKSUPER=$P($G(^ACK(509850.3,ACKDUZ,0)),U,6)
- K ^TMP("ACKQCPL",$J) S (ACKWT,ACKCNT)=0 F S ACKWT=$O(^ACK(509850.6,"AWAIT",2,ACKWT)) Q:'ACKWT I ACKSUPER!($D(^ACK(509850.6,"ST",ACKDUZ,ACKWT))) D
- .S ACKZNODE=$G(^ACK(509850.6,ACKWT,0))
- .I $P(ACKZNODE,U,8),$$EN1^DVBCTRN($P(ACKZNODE,U,2),"AUDIO",$P(ACKZNODE,U,8))>0 D
- ..S ACK5=$G(^ACK(509850.6,ACKWT,5))
- ..S ACKCNT=ACKCNT+1,ACKDFN=$G(^DPT(+$P(ACKZNODE,U,2),0))
- ..S Y=+ACKZNODE S:Y["." Y=$P(Y,".",1)
- ..I $D(ACK5) S Y=Y_$P(ACK5,U,8) ; Concatenate App. time to Visit Date
- ..X ^DD("DD") S Y=$P(Y,":",1,2),ACKVDT=Y,ACKSP=" "
- ..S ACKSSN=$E($P(ACKDFN,U,9),1,3)_"-"_$E($P(ACKDFN,U,9),4,5)_"-"_$E($P(ACKDFN,U,9),6,9)
- ..S ACKVDIV=$P(ACK5,U,1) ; Get division code
- ..S ACKSTN=$$GET1^DIQ(40.8,ACKVDIV,1) ; Get Division Station Number
- ..S ^TMP("ACKQCPL",$J,ACKCNT,ACKWT)=$E(ACKVDT_ACKSP,1,18)_$P(ACKDFN,U)_$E(ACKSP,$L($P(ACKDFN,U))+1,37)_ACKSSN_" "_$E(ACKSTN_ACKSP,1,7)
- ; If no exams
- I '$O(^TMP("ACKQCPL",$J,0)) D G EXIT
- . W !,$C(7)
- . W "No C&P exams awaiting adequation now." S DIRUT=1
- ;
- ; If only one exam
- I ACKCNT=1 D G:$D(DIRUT) EXIT G SET
- . W !,"There is only one C&P exam awaiting adequation.",!! D HEAD(0)
- . W !,^TMP("ACKQCPL",$J,1,$O(^TMP("ACKQCPL",$J,1,0))),!!!
- . ;
- . S ACKVIEN=$O(^TMP("ACKQCPL",$J,1,0))
- . W "Press RETURN to process this exam.",!
- . S ACKNUM=1 S DIR(0)="E" D ^DIR K DIR Q:$D(DIRUT)
- . ; Check this entry is not locked
- . L +^ACK(509850.6,ACKVIEN):2 E W !!,"This record is locked by another process - Please try again later.",!! S DIRUT=1 Q
- ;
- ;
- CHOICE ; Display list of C&P exams to adequate.
- D HEAD(1)
- S ACKNUM=0 F S ACKNUM=$O(^TMP("ACKQCPL",$J,ACKNUM)) Q:'ACKNUM!($D(DIRUT)) D
- .I $Y>(IOSL-5) D PAUSE^ACKQUTL Q:$D(DIRUT) W @IOF D HEAD(1)
- .W !,$J(ACKNUM,3),". ",^TMP("ACKQCPL",$J,ACKNUM,$O(^TMP("ACKQCPL",$J,ACKNUM,0)))
- ; Select one
- I $D(DIRUT) G EXIT
- CHOICE1 S DIR(0)="NA^1:"_ACKCNT,DIR("A")="Select, by number, the exam you wish to adequate: ",DIR("?")="Choose a number from the list of exams"
- W ! D ^DIR K DIR I $D(DIRUT) G EXIT
- S ACKNUM=Y
- ;
- SET ; Set ACKD0, ACKSFT, and DFN before exit and check for locking
- S ACKD0=$O(^TMP("ACKQCPL",$J,ACKNUM,0))
- ;
- ; Check this entry is not locked
- L +^ACK(509850.6,ACKD0):2 E W !!,"This record is locked by another process - Please try again later.",!! K ACKD0 G CHOICE1
- ;
- S DFN=+$P(^ACK(509850.6,ACKD0,0),U,2),ACKSFT=$P(^ACK(509850.6,ACKD0,0),U,8)
- ;
- EXIT ; Kill variables and return to calling routine.
- K ACKCNT,ACKDFN,ACKNUM,ACKSP,ACKSSN,ACKSUPER,ACKVDT,ACKWT,ACKZNODE
- K DIR,X,Y,^TMP("ACKQCPL",$J),ACKVIEN
- Q
- ;
- HEAD(ACKX) ; Draws Heading on screen
- W ! W:ACKX " " W "Visit Date/Time Name SSN Stn. #",!
- Q
- ;
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQCPL 3174 printed Mar 13, 2025@21:37:05 Page 2
- ACKQCPL ;AUG/JLTP BIR/PTD HCIOFO/BH-Lookup for C&P Exams Awaiting Adequation ; 04/22/96 14:16
- +1 ;;3.0;QUASAR;;Feb 11, 2000
- +2 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
- +3 ;
- BUILD ; Build array of exams user can adequate in ^TMP(.
- +1 NEW ACK5,ACKSTN,ACKDIV,ACKSTAT,ACKDUZ
- +2 SET ACKDUZ=$$PROVCHK^ACKQASU4(DUZ)
- if ACKDUZ=""
- SET ACKDUZ=" "
- +3 SET ACKSUPER=$PIECE($GET(^ACK(509850.3,ACKDUZ,0)),U,6)
- +4 KILL ^TMP("ACKQCPL",$JOB)
- SET (ACKWT,ACKCNT)=0
- FOR
- SET ACKWT=$ORDER(^ACK(509850.6,"AWAIT",2,ACKWT))
- if 'ACKWT
- QUIT
- IF ACKSUPER!($DATA(^ACK(509850.6,"ST",ACKDUZ,ACKWT)))
- Begin DoDot:1
- +5 SET ACKZNODE=$GET(^ACK(509850.6,ACKWT,0))
- +6 IF $PIECE(ACKZNODE,U,8)
- IF $$EN1^DVBCTRN($PIECE(ACKZNODE,U,2),"AUDIO",$PIECE(ACKZNODE,U,8))>0
- Begin DoDot:2
- +7 SET ACK5=$GET(^ACK(509850.6,ACKWT,5))
- +8 SET ACKCNT=ACKCNT+1
- SET ACKDFN=$GET(^DPT(+$PIECE(ACKZNODE,U,2),0))
- +9 SET Y=+ACKZNODE
- if Y["."
- SET Y=$PIECE(Y,".",1)
- +10 ; Concatenate App. time to Visit Date
- IF $DATA(ACK5)
- SET Y=Y_$PIECE(ACK5,U,8)
- +11 XECUTE ^DD("DD")
- SET Y=$PIECE(Y,":",1,2)
- SET ACKVDT=Y
- SET ACKSP=" "
- +12 SET ACKSSN=$EXTRACT($PIECE(ACKDFN,U,9),1,3)_"-"_$EXTRACT($PIECE(ACKDFN,U,9),4,5)_"-"_$EXTRACT($PIECE(ACKDFN,U,9),6,9)
- +13 ; Get division code
- SET ACKVDIV=$PIECE(ACK5,U,1)
- +14 ; Get Division Station Number
- SET ACKSTN=$$GET1^DIQ(40.8,ACKVDIV,1)
- +15 SET ^TMP("ACKQCPL",$JOB,ACKCNT,ACKWT)=$EXTRACT(ACKVDT_ACKSP,1,18)_$PIECE(ACKDFN,U)_$EXTRACT(ACKSP,$LENGTH($PIECE(ACKDFN,U))+1,37)_ACKSSN_" "_$EXTRACT(ACKSTN_ACKSP,1,7)
- End DoDot:2
- End DoDot:1
- +16 ; If no exams
- +17 IF '$ORDER(^TMP("ACKQCPL",$JOB,0))
- Begin DoDot:1
- +18 WRITE !,$CHAR(7)
- +19 WRITE "No C&P exams awaiting adequation now."
- SET DIRUT=1
- End DoDot:1
- GOTO EXIT
- +20 ;
- +21 ; If only one exam
- +22 IF ACKCNT=1
- Begin DoDot:1
- +23 WRITE !,"There is only one C&P exam awaiting adequation.",!!
- DO HEAD(0)
- +24 WRITE !,^TMP("ACKQCPL",$JOB,1,$ORDER(^TMP("ACKQCPL",$JOB,1,0))),!!!
- +25 ;
- +26 SET ACKVIEN=$ORDER(^TMP("ACKQCPL",$JOB,1,0))
- +27 WRITE "Press RETURN to process this exam.",!
- +28 SET ACKNUM=1
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- QUIT
- +29 ; Check this entry is not locked
- +30 LOCK +^ACK(509850.6,ACKVIEN):2
- IF '$TEST
- WRITE !!,"This record is locked by another process - Please try again later.",!!
- SET DIRUT=1
- QUIT
- End DoDot:1
- if $DATA(DIRUT)
- GOTO EXIT
- GOTO SET
- +31 ;
- +32 ;
- CHOICE ; Display list of C&P exams to adequate.
- +1 DO HEAD(1)
- +2 SET ACKNUM=0
- FOR
- SET ACKNUM=$ORDER(^TMP("ACKQCPL",$JOB,ACKNUM))
- if 'ACKNUM!($DATA(DIRUT))
- QUIT
- Begin DoDot:1
- +3 IF $Y>(IOSL-5)
- DO PAUSE^ACKQUTL
- if $DATA(DIRUT)
- QUIT
- WRITE @IOF
- DO HEAD(1)
- +4 WRITE !,$JUSTIFY(ACKNUM,3),". ",^TMP("ACKQCPL",$JOB,ACKNUM,$ORDER(^TMP("ACKQCPL",$JOB,ACKNUM,0)))
- End DoDot:1
- +5 ; Select one
- +6 IF $DATA(DIRUT)
- GOTO EXIT
- CHOICE1 SET DIR(0)="NA^1:"_ACKCNT
- SET DIR("A")="Select, by number, the exam you wish to adequate: "
- SET DIR("?")="Choose a number from the list of exams"
- +1 WRITE !
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- GOTO EXIT
- +2 SET ACKNUM=Y
- +3 ;
- SET ; Set ACKD0, ACKSFT, and DFN before exit and check for locking
- +1 SET ACKD0=$ORDER(^TMP("ACKQCPL",$JOB,ACKNUM,0))
- +2 ;
- +3 ; Check this entry is not locked
- +4 LOCK +^ACK(509850.6,ACKD0):2
- IF '$TEST
- WRITE !!,"This record is locked by another process - Please try again later.",!!
- KILL ACKD0
- GOTO CHOICE1
- +5 ;
- +6 SET DFN=+$PIECE(^ACK(509850.6,ACKD0,0),U,2)
- SET ACKSFT=$PIECE(^ACK(509850.6,ACKD0,0),U,8)
- +7 ;
- EXIT ; Kill variables and return to calling routine.
- +1 KILL ACKCNT,ACKDFN,ACKNUM,ACKSP,ACKSSN,ACKSUPER,ACKVDT,ACKWT,ACKZNODE
- +2 KILL DIR,X,Y,^TMP("ACKQCPL",$JOB),ACKVIEN
- +3 QUIT
- +4 ;
- HEAD(ACKX) ; Draws Heading on screen
- +1 WRITE !
- if ACKX
- WRITE " "
- WRITE "Visit Date/Time Name SSN Stn. #",!
- +2 QUIT
- +3 ;
- +4 ;
