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

ACKQUTL6.m

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