ACKQUTL6 ;HCIOFO/BH-A&SP Utilities routine ; 12/28/07 11:04am
;;3.0;QUASAR;**1,7,17**;Feb 11, 2000;Build 28
;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
;
DATACHEK(X,ACKVIEN) ; Checks that the input (X) is a valid time also checks that
; current user has supervisor status
;
I $$TIMECHEK^ACKQASU5(ACKVIEN,"") Q 0
S X=$$TTIME(X) Q X
;
;
SUPER(DUZ) ; Function passes back true if DUZ belongs to a supervisor
N ACKDUZ
S ACKDUZ=$$PROVCHK^ACKQASU4(DUZ)
I 'ACKDUZ Q 0
I $D(^ACK(509850.3,ACKDUZ,0)),$P(^(0),"^",6)=1 Q 1
Q 0
;
;
TTIME(X) ; Time input validation used within input transform of
; the Appointment time field (#55) of the visit file.
;
; X=Time entered by the user
; Return value either O if input was invalid or formatted
; time.
;
N Y,ACKFMT,ACKAMPM
I X="NOW"!(X="now") D NOW^%DTC S X=$P(%,".",2)
I X="NOO" S X="NOON"
;
S %DT="%DTS"
; S DIR(0)="D^::%DT"
S X="2990303@"_X
K Y
D ^%DT
;
I Y="-1" Q 0
S Y=$P(Y,".",2)
S ACKT="."_Y
;
S ACKFMT=Y
;. D AMPM
;. W ?30,"("_+$E(ACKFMT,1,2)_":"_$E(ACKFMT,3,4)_":"_$E(ACKFMT,5,6)_ACKAMPM_")"
;. D AMPM
;. W ?30,"("_+$E(ACKFMT,1,2)_":"_$E(ACKFMT,3,4)_ACKAMPM_")"
W ?30,"("_$$FMT(ACKFMT)_")"
Q ACKT
;
FMT(ACKFMT,ACKSTYL) ; convert Quasar Time to external format
; inputs:- ACKFMT - fileman time (internal) (reqd)
; can be passed in as 'date.time','.time' or just 'time'
; ACKSTYL - style of output (optional)
; where 0 = 12:mm[:ss] am/pm (no lead space)
; 1 = 12:mm[:ss] am/pm (lead space)
; 2 = 12:mm am/pm
N ACKHH,ACKAMPM
S ACKSTYL=+$G(ACKSTYL)
I ACKFMT["." S ACKFMT=$P(ACKFMT,".",2)
S ACKFMT=ACKFMT_"00000"
S ACKHH=+$E(ACKFMT,1,2)
G:ACKSTYL=1 FMT1
G:ACKSTYL=2 FMT2
FMT0 ; style 0 - 12:mm[:ss] am/pm (the default)
S ACKAMPM=" AM" I ACKHH>11,ACKHH<24 S ACKAMPM=" PM"
I ACKHH<1 S ACKHH=12
I ACKHH>12 S ACKHH=ACKHH-12
S ACKFMT=ACKHH_":"_$E(ACKFMT,3,4)_$S(+$E(ACKFMT,5,6)>0:":"_$E(ACKFMT,5,6),1:"")_ACKAMPM
Q ACKFMT
FMT1 ; style 1 - 12:mm[:ss] am/pm (with lead space if hour<10)
S ACKAMPM=" AM" I ACKHH>11,ACKHH<24 S ACKAMPM=" PM"
I ACKHH<1 S ACKHH=12
I ACKHH>12 S ACKHH=ACKHH-12
S ACKFMT=$J(ACKHH,2)_":"_$E(ACKFMT,3,4)_$S(+$E(ACKFMT,5,6)>0:":"_$E(ACKFMT,5,6),1:"")_ACKAMPM
Q ACKFMT
FMT2 ; style 2 - 12:mm am/pm
S ACKAMPM=" AM" I ACKHH>11,ACKHH<24 S ACKAMPM=" PM"
I ACKHH<1 S ACKHH=12
I ACKHH>12 S ACKHH=ACKHH-12
S ACKFMT=$J(ACKHH,2)_":"_$E(ACKFMT,3,4)_ACKAMPM
Q ACKFMT
;
DUPECHK(X,DA,ACKP) ; Check there are no previous duplicate entries
N ACKTGT,ACKCLIN,ACKVD,ACKPAT
S ACKPAT=ACKP
D GETS^DIQ(509850.6,DA_",",".01;1;2.6","I","ACKTGT")
S ACKVD=$G(ACKTGT(509850.6,DA_",",.01,"I")) I ACKVD="" Q 1
I ACKPAT="" S ACKPAT=$G(ACKTGT(509850.6,DA_",",1,"I")) I ACKPAT="" Q 1
S ACKCLIN=$G(ACKTGT(509850.6,DA_",",2.6,"I")) I ACKCLIN="" Q 1
I $D(^ACK(509850.6,"APCE",ACKPAT,ACKCLIN,ACKVD,X)) Q 0
Q 1
;
DUPCHK ; Called from xecutable help of Appointment Time field when ACKITME is
; defined. This will only be defined if DUPECHK returned false
W !!,"Quasar already has a Visit entry for this Patient, within the same Clinic,"
W !,"on the same date at the same time."
W !!,"Please re-enter a new Appointment Time.",!!
K ACKITME Q
;
;
CDR() ; COMPUTE SUGGESTED CDR BASED ON TREATING SPECIALTY
S VAIP("D")=ACKVD D IN5^VADPT S ACKTS=+$$GET1^DIQ(45.7,+VAIP(8),1,"I"),ACKCDN=$$GET1^DIQ(42.4,ACKTS,6)_".00"
S ACKCDP=$S($O(^ACK(509850,"B",ACKCDN,0)):$O(^(0)),1:0) I 'ACKCDP S ACKCDP=$O(^ACK(509850,"B","2611.00",0))
S ACKCDN=$P(^ACK(509850,ACKCDP,0),U),ACKCD=$P(^(0),U,2)
K %,%H,%I,ACKTS,ACKCDP,VAIP,VAERR
W !!,"Suggested CDR Account :",ACKCDN," ",ACKCD,!
Q ACKCDN
;
;----------------------------------------------------------------
; Routines and Utilities used within the Clinician Template
;
;
STAFFNO(X) ; Finds valid staff No. to be used when allocating next time
;
N ACKFIRST,ACKFIND,ACKX
S ACKFIRST=1
I X=9999 S X="0000" S ACKFIRST=0
D GETNEXT,FILE
Q
;
GETNEXT ;
S ACKFIND=0
F Q:ACKFIND D
. S ACKX=+X
. S X=X+1
. I X=9999,ACKFIRST S ACKFIRST=0 S X=0 Q
. I X=9999,'ACKFIRST S ACKFIND=1 Q
. S X=$E("0000",$L(X)+1,4)_X
. I '$D(^ACK(509850.3,"C",X)) S ACKFIND=1,X=ACKX Q
Q
;
FILE ;
S ^ACK(509850.3,"ALID")=$E("0000",$L(X)+1,4)_X
Q
;
;
IDATE(D0,Y) ; Checks that the entered Inactive date falls after the
; Active date (if one has been entered).
I Y="" Q 1 ; Its valid to not enter an inactivation date.
N ACKACT
S ACKACT=$$GET1^DIQ(509850.3,D0,.03,"I") I ACKACT="" Q 1
I Y<ACKACT Q 0
Q 1
;
ADATE(D0,Y) ; Checks that the entered Active date falls before the
; Inactive date (if one has been entered).
N ACKINA
S ACKINA=$$GET1^DIQ(509850.3,D0,.04,"I") I ACKINA="" Q 1
I Y>ACKINA Q 0
Q 1
;
STAFFREF(X,DA) ; Cross Reference called from Cross Reference 'Logic'
Q ;Disabled With the removal of "D" X-ref ACKQ*3*17
;
N ACKNAME
;ACKQ*3*17
;S ACKNAME=$$GET1^DIQ(8930.3,X_",",.01)
S ACKNAME=$$GET1^DIQ(200,X_",",.01)
S ^ACK(509850.3,"D",ACKNAME,DA)=""
Q
;
REINDEX() ; Re-Indexes 'D' Cross Reference of Staff file
Q ;Disabled With the removal of "D" X-ref ACKQ*3*17
; First checks that all ^USR(8930.3 entries that 509850.3 points to
; still exist
N ACK01,ACK,ACKARR,ACKCNT
K ACKARR
S ACK=0,ACKCNT=0
F S ACK=$O(^ACK(509850.3,ACK)) Q:'ACK D
. S ACK01=$P(^ACK(509850.3,ACK,0),"^",1)
. I '$D(^USR(8930.3,ACK01,0)) D SETARR(ACK)
;
I $D(ACKARR) D Q 0
. W !!,"Warning - The following user(s) have been deleted from the USR Class Membership"
. W !,"file (#8930.3)."
. W !,"Quasar's A&SP Staff file (#509850.3) points to this file."
. W !,"The Quasar staff member(s) need to be re-entered into the USR Class Membership"
. W !,"file (8930.3) and the associated Quasar staff record amended to point to this"
. W !,"new entry.",!!
. N ACK1
. S ACK1=""
. F S ACK1=$O(ACKARR(ACK1)) Q:ACK1="" D
. . W " "_ACKARR(ACK1),!
. W !!
. W "Please inform IRM/National VistA Support of this problem. This error"
. W !,"can be re-created by running this option again."
. W !!
;
N DA,D0,X,Y
K ^ACK(509850.3,"D")
S DIK="^ACK(509850.3,"
S DIK(1)=".07^D"
D ENALL^DIK
Q 1
;
SETARR(ACK) ;
Q ;Disabled With the removal of "D" X-ref ACKQ*3*17
;
N ACKNAME
S ACKNAME=""
F S ACKNAME=$O(^ACK(509850.3,"D",ACKNAME)) Q:ACKNAME="" D
. I $D(^ACK(509850.3,"D",ACKNAME,ACK)) S ACKCNT=ACKCNT+1 S ACKARR(ACKCNT)=ACKNAME
Q
;
LONG(ACKPC,ACKQPR) ; Displays Long Description of Procedure Code
;
Q
N ACKQ,ACKRES,ACKNEW,ACKSTR,ACK1,ACKQARR,ACKLEN,ACKCNT S ACKSTR="",ACKCNT=0
S ACK1=0
F S ACK1=$O(^ICPT(ACKPC,"D",ACK1)) Q:'ACK1 D
. S ACKNEW=^ICPT(ACKPC,"D",ACK1,0)
. S ACKNEW=$$STRIP(ACKNEW)
. I $G(ACKSTR)'="" S ACKNEW=ACKSTR_" "_ACKNEW
. S ACKLEN=$L(ACKNEW)
. I ACKLEN>54 D
. . I ACKLEN=55 S ACKCNT=ACKCNT+1,ACKQARR(ACKCNT)=ACKNEW S ACKSTR="" Q
. . S ACKRES=$$FORMAT(ACKNEW) S ACKNEW=$P(ACKRES,"^",1),ACKSTR=$P(ACKRES,"^",2),ACKCNT=ACKCNT+1,ACKQARR(ACKCNT)=ACKNEW
. I ACKLEN<55 S ACKSTR=ACKNEW
I $G(ACKSTR)'="" D
. S ACKQ=1
. F Q:'ACKQ D
. . S ACKNEW=ACKSTR S ACKRES=$$FORMAT(ACKNEW)
. . S ACKNEW=$P(ACKRES,"^",1),ACKSTR=$P(ACKRES,"^",2)
. . S ACKCNT=ACKCNT+1,ACKQARR(ACKCNT)=ACKNEW
. . I $G(ACKSTR)="" S ACKQ=0
;
; Display Array
;
I '$D(ACKQARR) Q
N ACKK1,ACKQUIT
S ACKK1="",ACKQUIT=0
W !!," Long Description: "
F S ACKK1=$O(ACKQARR(ACKK1)) Q:'ACKK1!(ACKQUIT) D
. I ACKK1'=1 W !," "
. W ACKQARR(ACKK1) I ACKQPR=1,ACKK1=3 W "..." S ACKQUIT=1
W !
;
Q
;
FORMAT(ACKNEW) ;
;
N ACKRES,ACKCCT,ACKEND,ACKN
I $L(ACKNEW)<56 S ACKRES=ACKNEW_"^"_"" Q ACKRES
S ACKCCT=0,ACKEND=0
F Q:ACKEND D
. S ACKCCT=ACKCCT+1
. I $L($P(ACKNEW," ",1,ACKCCT))<56 S ACKN=ACKCCT
. I $L($P(ACKNEW," ",1,ACKCCT))'<56 S ACKEND=1
S ACKRES=$P(ACKNEW," ",1,ACKN)_"^"_$P(ACKNEW," ",ACKN+1,999)
Q ACKRES
;
STRIP(ACKNEW) ;
N ACKARRAY,ACKCT,ACKLEN,ACKX,ACKY,ACKI
S ACKY="",ACKCT=0
S ACKLEN=$L(ACKNEW)
F ACKI=1:1:ACKLEN D
. S ACKX=$E(ACKNEW,ACKI,ACKI)
. I ACKX'=" " S ACKY=ACKY_ACKX
. I ACKX=" ",ACKY'="" S ACKCT=ACKCT+1 S ACKARRAY(ACKCT)=ACKY S ACKY=""
. I ACKI=ACKLEN,ACKY'="" S ACKCT=ACKCT+1 S ACKARRAY(ACKCT)=ACKY S ACKY=""
;
N ACKLOOP,ACKSTRG
S ACKLOOP=0,ACKSTRG=""
F S ACKLOOP=$O(ACKARRAY(ACKLOOP)) Q:ACKLOOP="" D
. S ACKSTRG=ACKSTRG_ACKARRAY(ACKLOOP)_" "
;
S ACKLEN=$L(ACKSTRG)
I $E(ACKSTRG,ACKLEN,ACKLEN)=" " S ACKSTRG=$E(ACKSTRG,1,ACKLEN-1)
;
Q ACKSTRG
PLIST(ACKPAT,ACKDC) ; Determines if an entry exists in the Problem file
; returns Status as first piece, Problem List IEN as second piece
; (Status^IEN)
; Status values - 1=Inactive, 2=Active
N ACKIFN,ACKPLQT
S (ACKIFN,ACKPLQT)=0
I $D(^AUPNPROB("AC",ACKPAT)) D
. F S ACKIFN=$O(^AUPNPROB("AC",ACKPAT,ACKIFN)) Q:(ACKIFN="") D Q:ACKPLQT
. .I $D(^AUPNPROB("B",ACKDC,ACKIFN)) S ACKPLQT=ACKIFN
I ACKPLQT Q $S($P($G(^AUPNPROB(ACKPLQT,0)),U,12)="A":2,1:1)_U_ACKPLQT
Q 0
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQUTL6 9242 printed Jun 11, 2024@22:18:19 Page 2
ACKQUTL6 ;HCIOFO/BH-A&SP Utilities routine ; 12/28/07 11:04am
+1 ;;3.0;QUASAR;**1,7,17**;Feb 11, 2000;Build 28
+2 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
+3 ;
DATACHEK(X,ACKVIEN) ; Checks that the input (X) is a valid time also checks that
+1 ; current user has supervisor status
+2 ;
+3 IF $$TIMECHEK^ACKQASU5(ACKVIEN,"")
QUIT 0
+4 SET X=$$TTIME(X)
QUIT X
+5 ;
+6 ;
SUPER(DUZ) ; Function passes back true if DUZ belongs to a supervisor
+1 NEW ACKDUZ
+2 SET ACKDUZ=$$PROVCHK^ACKQASU4(DUZ)
+3 IF 'ACKDUZ
QUIT 0
+4 IF $DATA(^ACK(509850.3,ACKDUZ,0))
IF $PIECE(^(0),"^",6)=1
QUIT 1
+5 QUIT 0
+6 ;
+7 ;
TTIME(X) ; Time input validation used within input transform of
+1 ; the Appointment time field (#55) of the visit file.
+2 ;
+3 ; X=Time entered by the user
+4 ; Return value either O if input was invalid or formatted
+5 ; time.
+6 ;
+7 NEW Y,ACKFMT,ACKAMPM
+8 IF X="NOW"!(X="now")
DO NOW^%DTC
SET X=$PIECE(%,".",2)
+9 IF X="NOO"
SET X="NOON"
+10 ;
+11 SET %DT="%DTS"
+12 ; S DIR(0)="D^::%DT"
+13 SET X="2990303@"_X
+14 KILL Y
+15 DO ^%DT
+16 ;
+17 IF Y="-1"
QUIT 0
+18 SET Y=$PIECE(Y,".",2)
+19 SET ACKT="."_Y
+20 ;
+21 SET ACKFMT=Y
+22 ;. D AMPM
+23 ;. W ?30,"("_+$E(ACKFMT,1,2)_":"_$E(ACKFMT,3,4)_":"_$E(ACKFMT,5,6)_ACKAMPM_")"
+24 ;. D AMPM
+25 ;. W ?30,"("_+$E(ACKFMT,1,2)_":"_$E(ACKFMT,3,4)_ACKAMPM_")"
+26 WRITE ?30,"("_$$FMT(ACKFMT)_")"
+27 QUIT ACKT
+28 ;
FMT(ACKFMT,ACKSTYL) ; convert Quasar Time to external format
+1 ; inputs:- ACKFMT - fileman time (internal) (reqd)
+2 ; can be passed in as 'date.time','.time' or just 'time'
+3 ; ACKSTYL - style of output (optional)
+4 ; where 0 = 12:mm[:ss] am/pm (no lead space)
+5 ; 1 = 12:mm[:ss] am/pm (lead space)
+6 ; 2 = 12:mm am/pm
+7 NEW ACKHH,ACKAMPM
+8 SET ACKSTYL=+$GET(ACKSTYL)
+9 IF ACKFMT["."
SET ACKFMT=$PIECE(ACKFMT,".",2)
+10 SET ACKFMT=ACKFMT_"00000"
+11 SET ACKHH=+$EXTRACT(ACKFMT,1,2)
+12 if ACKSTYL=1
GOTO FMT1
+13 if ACKSTYL=2
GOTO FMT2
FMT0 ; style 0 - 12:mm[:ss] am/pm (the default)
+1 SET ACKAMPM=" AM"
IF ACKHH>11
IF ACKHH<24
SET ACKAMPM=" PM"
+2 IF ACKHH<1
SET ACKHH=12
+3 IF ACKHH>12
SET ACKHH=ACKHH-12
+4 SET ACKFMT=ACKHH_":"_$EXTRACT(ACKFMT,3,4)_$SELECT(+$EXTRACT(ACKFMT,5,6)>0:":"_$EXTRACT(ACKFMT,5,6),1:"")_ACKAMPM
+5 QUIT ACKFMT
FMT1 ; style 1 - 12:mm[:ss] am/pm (with lead space if hour<10)
+1 SET ACKAMPM=" AM"
IF ACKHH>11
IF ACKHH<24
SET ACKAMPM=" PM"
+2 IF ACKHH<1
SET ACKHH=12
+3 IF ACKHH>12
SET ACKHH=ACKHH-12
+4 SET ACKFMT=$JUSTIFY(ACKHH,2)_":"_$EXTRACT(ACKFMT,3,4)_$SELECT(+$EXTRACT(ACKFMT,5,6)>0:":"_$EXTRACT(ACKFMT,5,6),1:"")_ACKAMPM
+5 QUIT ACKFMT
FMT2 ; style 2 - 12:mm am/pm
+1 SET ACKAMPM=" AM"
IF ACKHH>11
IF ACKHH<24
SET ACKAMPM=" PM"
+2 IF ACKHH<1
SET ACKHH=12
+3 IF ACKHH>12
SET ACKHH=ACKHH-12
+4 SET ACKFMT=$JUSTIFY(ACKHH,2)_":"_$EXTRACT(ACKFMT,3,4)_ACKAMPM
+5 QUIT ACKFMT
+6 ;
DUPECHK(X,DA,ACKP) ; Check there are no previous duplicate entries
+1 NEW ACKTGT,ACKCLIN,ACKVD,ACKPAT
+2 SET ACKPAT=ACKP
+3 DO GETS^DIQ(509850.6,DA_",",".01;1;2.6","I","ACKTGT")
+4 SET ACKVD=$GET(ACKTGT(509850.6,DA_",",.01,"I"))
IF ACKVD=""
QUIT 1
+5 IF ACKPAT=""
SET ACKPAT=$GET(ACKTGT(509850.6,DA_",",1,"I"))
IF ACKPAT=""
QUIT 1
+6 SET ACKCLIN=$GET(ACKTGT(509850.6,DA_",",2.6,"I"))
IF ACKCLIN=""
QUIT 1
+7 IF $DATA(^ACK(509850.6,"APCE",ACKPAT,ACKCLIN,ACKVD,X))
QUIT 0
+8 QUIT 1
+9 ;
DUPCHK ; Called from xecutable help of Appointment Time field when ACKITME is
+1 ; defined. This will only be defined if DUPECHK returned false
+2 WRITE !!,"Quasar already has a Visit entry for this Patient, within the same Clinic,"
+3 WRITE !,"on the same date at the same time."
+4 WRITE !!,"Please re-enter a new Appointment Time.",!!
+5 KILL ACKITME
QUIT
+6 ;
+7 ;
CDR() ; COMPUTE SUGGESTED CDR BASED ON TREATING SPECIALTY
+1 SET VAIP("D")=ACKVD
DO IN5^VADPT
SET ACKTS=+$$GET1^DIQ(45.7,+VAIP(8),1,"I")
SET ACKCDN=$$GET1^DIQ(42.4,ACKTS,6)_".00"
+2 SET ACKCDP=$SELECT($ORDER(^ACK(509850,"B",ACKCDN,0)):$ORDER(^(0)),1:0)
IF 'ACKCDP
SET ACKCDP=$ORDER(^ACK(509850,"B","2611.00",0))
+3 SET ACKCDN=$PIECE(^ACK(509850,ACKCDP,0),U)
SET ACKCD=$PIECE(^(0),U,2)
+4 KILL %,%H,%I,ACKTS,ACKCDP,VAIP,VAERR
+5 WRITE !!,"Suggested CDR Account :",ACKCDN," ",ACKCD,!
+6 QUIT ACKCDN
+7 ;
+8 ;----------------------------------------------------------------
+9 ; Routines and Utilities used within the Clinician Template
+10 ;
+11 ;
STAFFNO(X) ; Finds valid staff No. to be used when allocating next time
+1 ;
+2 NEW ACKFIRST,ACKFIND,ACKX
+3 SET ACKFIRST=1
+4 IF X=9999
SET X="0000"
SET ACKFIRST=0
+5 DO GETNEXT
DO FILE
+6 QUIT
+7 ;
GETNEXT ;
+1 SET ACKFIND=0
+2 FOR
if ACKFIND
QUIT
Begin DoDot:1
+3 SET ACKX=+X
+4 SET X=X+1
+5 IF X=9999
IF ACKFIRST
SET ACKFIRST=0
SET X=0
QUIT
+6 IF X=9999
IF 'ACKFIRST
SET ACKFIND=1
QUIT
+7 SET X=$EXTRACT("0000",$LENGTH(X)+1,4)_X
+8 IF '$DATA(^ACK(509850.3,"C",X))
SET ACKFIND=1
SET X=ACKX
QUIT
End DoDot:1
+9 QUIT
+10 ;
FILE ;
+1 SET ^ACK(509850.3,"ALID")=$EXTRACT("0000",$LENGTH(X)+1,4)_X
+2 QUIT
+3 ;
+4 ;
IDATE(D0,Y) ; Checks that the entered Inactive date falls after the
+1 ; Active date (if one has been entered).
+2 ; Its valid to not enter an inactivation date.
IF Y=""
QUIT 1
+3 NEW ACKACT
+4 SET ACKACT=$$GET1^DIQ(509850.3,D0,.03,"I")
IF ACKACT=""
QUIT 1
+5 IF Y<ACKACT
QUIT 0
+6 QUIT 1
+7 ;
ADATE(D0,Y) ; Checks that the entered Active date falls before the
+1 ; Inactive date (if one has been entered).
+2 NEW ACKINA
+3 SET ACKINA=$$GET1^DIQ(509850.3,D0,.04,"I")
IF ACKINA=""
QUIT 1
+4 IF Y>ACKINA
QUIT 0
+5 QUIT 1
+6 ;
STAFFREF(X,DA) ; Cross Reference called from Cross Reference 'Logic'
+1 ;Disabled With the removal of "D" X-ref ACKQ*3*17
QUIT
+2 ;
+3 NEW ACKNAME
+4 ;ACKQ*3*17
+5 ;S ACKNAME=$$GET1^DIQ(8930.3,X_",",.01)
+6 SET ACKNAME=$$GET1^DIQ(200,X_",",.01)
+7 SET ^ACK(509850.3,"D",ACKNAME,DA)=""
+8 QUIT
+9 ;
REINDEX() ; Re-Indexes 'D' Cross Reference of Staff file
+1 ;Disabled With the removal of "D" X-ref ACKQ*3*17
QUIT
+2 ; First checks that all ^USR(8930.3 entries that 509850.3 points to
+3 ; still exist
+4 NEW ACK01,ACK,ACKARR,ACKCNT
+5 KILL ACKARR
+6 SET ACK=0
SET ACKCNT=0
+7 FOR
SET ACK=$ORDER(^ACK(509850.3,ACK))
if 'ACK
QUIT
Begin DoDot:1
+8 SET ACK01=$PIECE(^ACK(509850.3,ACK,0),"^",1)
+9 IF '$DATA(^USR(8930.3,ACK01,0))
DO SETARR(ACK)
End DoDot:1
+10 ;
+11 IF $DATA(ACKARR)
Begin DoDot:1
+12 WRITE !!,"Warning - The following user(s) have been deleted from the USR Class Membership"
+13 WRITE !,"file (#8930.3)."
+14 WRITE !,"Quasar's A&SP Staff file (#509850.3) points to this file."
+15 WRITE !,"The Quasar staff member(s) need to be re-entered into the USR Class Membership"
+16 WRITE !,"file (8930.3) and the associated Quasar staff record amended to point to this"
+17 WRITE !,"new entry.",!!
+18 NEW ACK1
+19 SET ACK1=""
+20 FOR
SET ACK1=$ORDER(ACKARR(ACK1))
if ACK1=""
QUIT
Begin DoDot:2
+21 WRITE " "_ACKARR(ACK1),!
End DoDot:2
+22 WRITE !!
+23 WRITE "Please inform IRM/National VistA Support of this problem. This error"
+24 WRITE !,"can be re-created by running this option again."
+25 WRITE !!
End DoDot:1
QUIT 0
+26 ;
+27 NEW DA,D0,X,Y
+28 KILL ^ACK(509850.3,"D")
+29 SET DIK="^ACK(509850.3,"
+30 SET DIK(1)=".07^D"
+31 DO ENALL^DIK
+32 QUIT 1
+33 ;
SETARR(ACK) ;
+1 ;Disabled With the removal of "D" X-ref ACKQ*3*17
QUIT
+2 ;
+3 NEW ACKNAME
+4 SET ACKNAME=""
+5 FOR
SET ACKNAME=$ORDER(^ACK(509850.3,"D",ACKNAME))
if ACKNAME=""
QUIT
Begin DoDot:1
+6 IF $DATA(^ACK(509850.3,"D",ACKNAME,ACK))
SET ACKCNT=ACKCNT+1
SET ACKARR(ACKCNT)=ACKNAME
End DoDot:1
+7 QUIT
+8 ;
LONG(ACKPC,ACKQPR) ; Displays Long Description of Procedure Code
+1 ;
+2 QUIT
+3 NEW ACKQ,ACKRES,ACKNEW,ACKSTR,ACK1,ACKQARR,ACKLEN,ACKCNT
SET ACKSTR=""
SET ACKCNT=0
+4 SET ACK1=0
+5 FOR
SET ACK1=$ORDER(^ICPT(ACKPC,"D",ACK1))
if 'ACK1
QUIT
Begin DoDot:1
+6 SET ACKNEW=^ICPT(ACKPC,"D",ACK1,0)
+7 SET ACKNEW=$$STRIP(ACKNEW)
+8 IF $GET(ACKSTR)'=""
SET ACKNEW=ACKSTR_" "_ACKNEW
+9 SET ACKLEN=$LENGTH(ACKNEW)
+10 IF ACKLEN>54
Begin DoDot:2
+11 IF ACKLEN=55
SET ACKCNT=ACKCNT+1
SET ACKQARR(ACKCNT)=ACKNEW
SET ACKSTR=""
QUIT
+12 SET ACKRES=$$FORMAT(ACKNEW)
SET ACKNEW=$PIECE(ACKRES,"^",1)
SET ACKSTR=$PIECE(ACKRES,"^",2)
SET ACKCNT=ACKCNT+1
SET ACKQARR(ACKCNT)=ACKNEW
End DoDot:2
+13 IF ACKLEN<55
SET ACKSTR=ACKNEW
End DoDot:1
+14 IF $GET(ACKSTR)'=""
Begin DoDot:1
+15 SET ACKQ=1
+16 FOR
if 'ACKQ
QUIT
Begin DoDot:2
+17 SET ACKNEW=ACKSTR
SET ACKRES=$$FORMAT(ACKNEW)
+18 SET ACKNEW=$PIECE(ACKRES,"^",1)
SET ACKSTR=$PIECE(ACKRES,"^",2)
+19 SET ACKCNT=ACKCNT+1
SET ACKQARR(ACKCNT)=ACKNEW
+20 IF $GET(ACKSTR)=""
SET ACKQ=0
End DoDot:2
End DoDot:1
+21 ;
+22 ; Display Array
+23 ;
+24 IF '$DATA(ACKQARR)
QUIT
+25 NEW ACKK1,ACKQUIT
+26 SET ACKK1=""
SET ACKQUIT=0
+27 WRITE !!," Long Description: "
+28 FOR
SET ACKK1=$ORDER(ACKQARR(ACKK1))
if 'ACKK1!(ACKQUIT)
QUIT
Begin DoDot:1
+29 IF ACKK1'=1
WRITE !," "
+30 WRITE ACKQARR(ACKK1)
IF ACKQPR=1
IF ACKK1=3
WRITE "..."
SET ACKQUIT=1
End DoDot:1
+31 WRITE !
+32 ;
+33 QUIT
+34 ;
FORMAT(ACKNEW) ;
+1 ;
+2 NEW ACKRES,ACKCCT,ACKEND,ACKN
+3 IF $LENGTH(ACKNEW)<56
SET ACKRES=ACKNEW_"^"_""
QUIT ACKRES
+4 SET ACKCCT=0
SET ACKEND=0
+5 FOR
if ACKEND
QUIT
Begin DoDot:1
+6 SET ACKCCT=ACKCCT+1
+7 IF $LENGTH($PIECE(ACKNEW," ",1,ACKCCT))<56
SET ACKN=ACKCCT
+8 IF $LENGTH($PIECE(ACKNEW," ",1,ACKCCT))'<56
SET ACKEND=1
End DoDot:1
+9 SET ACKRES=$PIECE(ACKNEW," ",1,ACKN)_"^"_$PIECE(ACKNEW," ",ACKN+1,999)
+10 QUIT ACKRES
+11 ;
STRIP(ACKNEW) ;
+1 NEW ACKARRAY,ACKCT,ACKLEN,ACKX,ACKY,ACKI
+2 SET ACKY=""
SET ACKCT=0
+3 SET ACKLEN=$LENGTH(ACKNEW)
+4 FOR ACKI=1:1:ACKLEN
Begin DoDot:1
+5 SET ACKX=$EXTRACT(ACKNEW,ACKI,ACKI)
+6 IF ACKX'=" "
SET ACKY=ACKY_ACKX
+7 IF ACKX=" "
IF ACKY'=""
SET ACKCT=ACKCT+1
SET ACKARRAY(ACKCT)=ACKY
SET ACKY=""
+8 IF ACKI=ACKLEN
IF ACKY'=""
SET ACKCT=ACKCT+1
SET ACKARRAY(ACKCT)=ACKY
SET ACKY=""
End DoDot:1
+9 ;
+10 NEW ACKLOOP,ACKSTRG
+11 SET ACKLOOP=0
SET ACKSTRG=""
+12 FOR
SET ACKLOOP=$ORDER(ACKARRAY(ACKLOOP))
if ACKLOOP=""
QUIT
Begin DoDot:1
+13 SET ACKSTRG=ACKSTRG_ACKARRAY(ACKLOOP)_" "
End DoDot:1
+14 ;
+15 SET ACKLEN=$LENGTH(ACKSTRG)
+16 IF $EXTRACT(ACKSTRG,ACKLEN,ACKLEN)=" "
SET ACKSTRG=$EXTRACT(ACKSTRG,1,ACKLEN-1)
+17 ;
+18 QUIT ACKSTRG
PLIST(ACKPAT,ACKDC) ; Determines if an entry exists in the Problem file
+1 ; returns Status as first piece, Problem List IEN as second piece
+2 ; (Status^IEN)
+3 ; Status values - 1=Inactive, 2=Active
+4 NEW ACKIFN,ACKPLQT
+5 SET (ACKIFN,ACKPLQT)=0
+6 IF $DATA(^AUPNPROB("AC",ACKPAT))
Begin DoDot:1
+7 FOR
SET ACKIFN=$ORDER(^AUPNPROB("AC",ACKPAT,ACKIFN))
if (ACKIFN="")
QUIT
Begin DoDot:2
+8 IF $DATA(^AUPNPROB("B",ACKDC,ACKIFN))
SET ACKPLQT=ACKIFN
End DoDot:2
if ACKPLQT
QUIT
End DoDot:1
+9 IF ACKPLQT
QUIT $SELECT($PIECE($GET(^AUPNPROB(ACKPLQT,0)),U,12)="A":2,1:1)_U_ACKPLQT
+10 QUIT 0
+11 ;
