- 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 Jan 18, 2025@03:34:04 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 ;