| [613] | 1 | ACKQUTL ;AUG/JLTP BIR/PTD HCIOFO/BH-QUASAR Utility Routine ; [ 06/06/99 10:03 ]
|
|---|
| 2 | V ;;3.0;QUASAR;;Feb 11, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ;
|
|---|
| 6 | CNTR(X) ; "CENTER" FUNCTION
|
|---|
| 7 | D:'$D(IOM) HOME^%ZIS W ?(IOM\2-($L(X)\2)),X
|
|---|
| 8 | Q
|
|---|
| 9 | ;
|
|---|
| 10 | MIXC(X) ; CHANGES X TO MIXED CASE
|
|---|
| 11 | N I,Y,Y1
|
|---|
| 12 | S Y=$$LOWC(X),X=""
|
|---|
| 13 | F I=1:1:$L(Y) S Y1=$E(Y,I),X=X_$S(I=1:$$UPC(Y1),$E(Y,I-1)?1P:$$UPC(Y1),1:Y1)
|
|---|
| 14 | Q X
|
|---|
| 15 | ;
|
|---|
| 16 | SSN(X) ; FORMAT SSN
|
|---|
| 17 | Q:X'?9N X Q $E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,9)
|
|---|
| 18 | ;
|
|---|
| 19 | LOWC(X) ; CONVERT X TO LOWERCASE
|
|---|
| 20 | Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
|
|---|
| 21 | ;
|
|---|
| 22 | UPC(X) ; CONVERT X TO UPPERCASE
|
|---|
| 23 | Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
|---|
| 24 | ;
|
|---|
| 25 | NUMDT(X1,X2) ; LIKE FILEMAN'S GREAT NUMDATE
|
|---|
| 26 | S:'$D(X2) X2="/" I $G(X1)'?7N.".".6N Q ""
|
|---|
| 27 | Q $E(X1,4,5)_X2_$E(X1,6,7)_X2_$E(X1,2,3)
|
|---|
| 28 | ;
|
|---|
| 29 | XDAT(X) ; FILEMAN INTERNAL TO EXTERNAL
|
|---|
| 30 | N MO,DA,YR Q:X="" X
|
|---|
| 31 | S MO=$E(X,4,5),DA=$E(X,6,7),YR=1700+$E(X,1,3)
|
|---|
| 32 | S MO(1)=$S(MO:$P("January$February$March$April$May$June$July$August$September$October$November$December","$",+MO),1:"")
|
|---|
| 33 | S X=YR S:+DA X=+DA_", "_X S:MO X=MO(1)_" "_X
|
|---|
| 34 | Q X
|
|---|
| 35 | ;
|
|---|
| 36 | FTIME(X) ;
|
|---|
| 37 | S X=$P(X,".",2)_"0000"
|
|---|
| 38 | Q $E(X,1,2)_":"_$E(X,3,4)
|
|---|
| 39 | ;
|
|---|
| 40 | STACT(ACKXX,ACKXX1) ;
|
|---|
| 41 | ;Entry point to determine if staff member ACKXX is/was active on
|
|---|
| 42 | ;date ACKXX1. If ACKXX1 is undefined, TODAY is used.
|
|---|
| 43 | ;Returns the following codes: 0=active, -1=not a&sp staff
|
|---|
| 44 | ;-2=student, -3=never activated, -4=inactivated on or before X1
|
|---|
| 45 | ;-5=not activated until after X1, -6=other provider (health technician)
|
|---|
| 46 | I '$D(^ACK(509850.3,+$G(ACKXX),0)) Q -1
|
|---|
| 47 | N ZERONODE,ACTIVE,INACTIVE,STANDING,DATE
|
|---|
| 48 | S DATE=$S(+$G(ACKXX1):ACKXX1,1:DT),ZERONODE=^ACK(509850.3,+ACKXX,0),STANDING=$P(ZERONODE,U,2),ACTIVE=$P(ZERONODE,U,3),INACTIVE=$P(ZERONODE,U,4)
|
|---|
| 49 | Q $S('ACTIVE:-3,ACTIVE>DATE:-5,(INACTIVE)&((INACTIVE<DATE)!(INACTIVE=DATE)):-4,"S"[STANDING:-2,"O"[STANDING:-6,1:0)
|
|---|
| 50 | ;
|
|---|
| 51 | YN(X) ; YES OR NO READER
|
|---|
| 52 | K DTOUT,DUOUT,DIRUT
|
|---|
| 53 | S X("B")=$S('$D(X):"",X:"Y",1:"N")
|
|---|
| 54 | ASKYN W " (Y/N) " W:X("B")]"" X("B")_"// " R X:DTIME S:'$T DTOUT=1 S:X="" X=X("B"),X("D")=1 I U[X!($D(DTOUT)) S DIRUT=1 S:X=U DUOUT=1 Q -1
|
|---|
| 55 | I "??"[X W !,"Answer Y for Yes or N for No." G ASKYN
|
|---|
| 56 | S X=$$UPC(X)
|
|---|
| 57 | I $E("YES",1,$L(X))=X W $S($D(X("D")):" (YES)",1:$E("YES",$L(X)+1,3)) Q 1
|
|---|
| 58 | I $E("NO",1,$L(X))=X W $S($D(X("D")):" (NO)",1:$E("NO",$L(X)+1,3)) Q 0
|
|---|
| 59 | W " ??",!,$C(7) G ASKYN
|
|---|
| 60 | ;
|
|---|
| 61 | PAUSE N DIR,DTOUT,DUOUT,JJ,SS,X,Y
|
|---|
| 62 | S SS=22-$Y F JJ=1:1:SS W !
|
|---|
| 63 | S DIR(0)="E" D ^DIR S:$D(DUOUT)!($D(DTOUT)) DIRUT=1 Q
|
|---|
| 64 | ;
|
|---|
| 65 | TRIGCP ; TRIGGER OF C AND P STATUS FIELD FROM #2.5, #4.17, & #4.19
|
|---|
| 66 | N Y
|
|---|
| 67 | S Y(0)=$G(^ACK(509850.6,DA,0)),Y(4)=$G(^(4)),Y(1)=$P(Y(0),U,5)
|
|---|
| 68 | S Y(2)=$P(Y(4),U,17),Y(3)=$P(Y(4),U,19)
|
|---|
| 69 | S X=$S(('Y(1)&('Y(2))):0,Y(3)]"":3,Y(2)]"":2,1:1)
|
|---|
| 70 | Q
|
|---|
| 71 | ;
|
|---|
| 72 | HTIM(%H,%S) ;
|
|---|
| 73 | ; Expected Input: %H = Full $H, %S = 1 if seconds desired
|
|---|
| 74 | N X
|
|---|
| 75 | S:'$D(%H) %H=$H S:%H["," %H=$P(%H,",",2)
|
|---|
| 76 | S X(3)=$$PAD(%H#60,"R",2,"0"),%H=%H\60
|
|---|
| 77 | S X(2)=$$PAD(%H#60,"R",2,"0"),%H=$$PAD(%H\60,"R",2,0)
|
|---|
| 78 | S X=%H_":"_X(2)_$S('$D(%S):"",'%S:"",1:":"_X(3))
|
|---|
| 79 | Q X
|
|---|
| 80 | ;
|
|---|
| 81 | PAD(X,X1,X2,X3) ;
|
|---|
| 82 | ; Required Input: X = String to Pad, X1 = "R" or "L" (right/left justify)
|
|---|
| 83 | ; X2 = Number of Spaces, X3 = Pad character
|
|---|
| 84 | F Q:$L(X)'<X2 S X=$S(X1="R":X3_X,1:X_X3)
|
|---|
| 85 | Q X
|
|---|
| 86 | ;
|
|---|
| 87 | BFY(X) ; RETURNS FM BEGIN OF FY FOR DATE X
|
|---|
| 88 | N M,D,Y S M=$E(X,4,5),D="00",Y=$E(X,1,3)-(M<10),M=10
|
|---|
| 89 | Q Y_M_D
|
|---|
| 90 | ;
|
|---|
| 91 | INTRO ; QUASAR Introduction:
|
|---|
| 92 | ; Called by the entry action of the ACKQAS SUPER menu option.
|
|---|
| 93 | ;
|
|---|
| 94 | K %ZIS S IOP="HOME" D ^%ZIS K %ZIS,IOP
|
|---|
| 95 | W @IOF
|
|---|
| 96 | W ! D CNTR("Quality:")
|
|---|
| 97 | W ! D CNTR("Audiology and Speech")
|
|---|
| 98 | W ! D CNTR("Analysis and Reporting")
|
|---|
| 99 | W ! D CNTR("(QUASAR)")
|
|---|
| 100 | W !! D CNTR("Version "_$P($T(V),";",3))
|
|---|
| 101 | W !
|
|---|
| 102 | Q
|
|---|
| 103 | IVD ; INITIAL VISIT DATE ** TRIGGERED FROM PATIENT NAME ***
|
|---|
| 104 | N Y,DDD,DD,DFN,D0,%DT
|
|---|
| 105 | S DFN=X,X=$S('$D(^ACK(509850.2,DFN,0)):"",'$P(^(0),U,2):"",1:$P(^(0),U,2))
|
|---|
| 106 | I 'X D
|
|---|
| 107 | . F D Q:X=""!(X'>DT)
|
|---|
| 108 | .. S Y=ACKVD D DD^%DT S %DT="AEP",%DT("A")="INITIAL VISIT DATE: "
|
|---|
| 109 | .. S %DT("B")=Y D ^%DT K %DT S X=$S(Y<1:"",1:Y)
|
|---|
| 110 | .. I X>DT W !,"No Future Dates Allowed",!
|
|---|
| 111 | K A1
|
|---|
| 112 | Q
|
|---|
| 113 | ;
|
|---|
| 114 | ADDPROV(ACKVIEN,X) ; Add Procedure Provider to List of Secondary
|
|---|
| 115 | ; Providers if it is not already there.
|
|---|
| 116 | ; X=Provider
|
|---|
| 117 | ; ACKVIEN=IEN of Visit
|
|---|
| 118 | ;
|
|---|
| 119 | N ACK2,ACKMSG,ACKTGT,ACKARR,ACKARR1
|
|---|
| 120 | D LIST^DIC(509850.66,","_ACKVIEN_",",".01","I","*","","","","","","ACKTGT","ACKMSG")
|
|---|
| 121 | S ACK2=""
|
|---|
| 122 | F S ACK2=$O(ACKTGT("DILIST",1,ACK2)) Q:ACK2="" D
|
|---|
| 123 | . S ACKARR(ACKTGT("DILIST",1,ACK2))=""
|
|---|
| 124 | S ACKPRIM=$$GET1^DIQ(509850.6,ACKVIEN_",",6,"I")
|
|---|
| 125 | I ACKPRIM S ACKARR(ACKPRIM)=""
|
|---|
| 126 | I $D(ACKARR(X)) Q
|
|---|
| 127 | S ACKARR1(509850.66,"+1,"_ACKVIEN_",",.01)=X
|
|---|
| 128 | D UPDATE^DIE("","ACKARR1","","")
|
|---|
| 129 | Q
|
|---|
| 130 | ;
|
|---|
