SCRPU3 ;ALB/CMM - GENERIC UTILITIES ; 9/26/05 8:50am
;;5.3;Scheduling;**41,45,52,140,181,177,432,433,346,1015**;AUG 13, 1993;Build 21
;IHS/ANMC/LJF 11/01/2000 bypass %ZIS call if using list template
; 11/02/2000 added checks for list template
;
ELIG(DFN) ;
;Gets Primary Eligibility
N PRIM
I '$D(^DPT(DFN,.36)) Q 0
I '$D(^DIC(8,+$P(^DPT(DFN,.36),"^"),0)) Q 0
S PRIM=$P($G(^DIC(8,$P($G(^DPT(DFN,.36)),"^"),0)),"^",9)
;MAS Primary Eligibility Code
S PRIM=$P($G(^DIC(8.1,PRIM,0)),"^")
;
S PRIM=$TR(PRIM,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
I PRIM="NON-SERVICE CONNECTED" S PRIM="NSC"
I PRIM["SERVICE CONNECTED" S PRIM=$P(PRIM,"SERVICE CONNECTED")_"SC"_$P(PRIM,"SERVICE CONNECTED",2,999)
I PRIM["LESS THAN" S PRIM=$P(PRIM,"LESS THAN")_"<"_$P(PRIM,"LESS THAN",2,999)
I PRIM[" TO " S PRIM=$P(PRIM," TO ")_"-"_$P(PRIM," TO ",2,999)
I PRIM["%" S PRIM=$TR(PRIM,"%","")
S PRIM=$E(PRIM,1,9)
Q PRIM
;
GETNEXT(DFN,CLN) ;
;Get next appointment for patient (DFN) at Clinic (CLN)
;Returning the date in 00/00/0000 format
N NEXT,APPT,FOUND
;
N SDARRAY,SDCOUNT,SDDATE,SDAPPT,SDSTATUS,%
; Tell SDAPI that we want only the next appointment based on:
; Date SDARRAY(1)=Today's Date;
; Clinic SDARRAY(2)=CLN
; Patient SDARRAY(4)=DFN
; Status SDARRAY(3)="R;I;NS;NSR;NT"
; KEPT/INPATIENT/NOSHOW/NOSHOWRESCHED/NOACTIONTAKEN
; and that we want to have field 3 (appt status) returned
; SDARRAY("FLDS")="3"
; DATA will be returned in ^TMP($J,"SDAMA301",DFN,CLN,SDDATE)
;
S FOUND=0,NEXT=""
I $G(CLN)=""!($G(DFN)="") Q NEXT
D NOW^%DTC S SDARRAY(1)=$P(%,".",1)_";"
S SDARRAY(2)=CLN,SDARRAY(3)="R;I;NS;NSR;NT",SDARRAY(4)=DFN,SDARRAY("FLDS")="3",SDARRAY("MAX")=1
S SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY)
I SDCOUNT>0 S SDDATE="" S SDDATE=$O(^TMP($J,"SDAMA301",DFN,CLN,SDDATE)) D
.S NEXT=$TR($$FMTE^XLFDT(SDDATE,"5DF")," ","0")
I SDCOUNT<0 D ;do processing for errors
.; None to do in this case -- return null
.Q
; when finished with all processing, kill SDAPI output array
K ^TMP($J,"SDAMA301")
Q NEXT
;
GETLAST(DFN,CLN) ;
;Get last appointment for patient (DFN) at Clinic (CLN)
;Returning the date in 00/00/0000 format
N LAST,APPT,FOUND,STATUS
N SDARRAY,SDCOUNT,SDDATE,SDAPPT,SDSTATUS,%
; Tell SDAPI that we want only the next appointment based on:
; Date SDARRAY(1)=;Today's Date
; Clinic SDARRAY(2)=CLN
; Patient SDARRAY(4)=DFN
; Status SDARRAY(3)="R;I;NT"
; MAX SDARRAY("MAX")=-1
; and that we want to have field 3 (appt status) returned
; SDARRAY("FLDS")="3"
; DATA will be returned in ^TMP($J,"SDAMA301",DFN,CLN,SDDATE)
;
S FOUND=0,LAST=""
I $G(CLN)=""!($G(DFN)="") Q LAST
D NOW^%DTC S SDARRAY(1)=";"_$P(%,".",1)
S SDARRAY(2)=CLN,SDARRAY(3)="R;I;NT",SDARRAY(4)=DFN,SDARRAY("MAX")=-1
S SDARRAY("FLDS")="3"
S SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY)
I SDCOUNT>0 S SDDATE="" D
.S SDDATE=$O(^TMP($J,"SDAMA301",DFN,CLN,SDDATE))
.S LAST=$TR($$FMTE^XLFDT(SDDATE,"5DF")," ","0")
I SDCOUNT<0 D ;do processing for errors
.Q ; None to do in this case
; when finished with all processing, kill SDAPI output array
K ^TMP($J,"SDAMA301")
Q LAST
;
PDEVICE() ;
;Generic Printer Call
N TION,POP
S %ZIS="QN" D ^%ZIS K %ZIS Q:POP!(ION="^") -1
S TION=ION
I $D(IO("Q")) S TION="Q;"_TION
Q TION_"^"_IOST
;
GETTIME() ;
;Prompt for Queue Time
N X,Y
S DIR(0)="D^::RFE",DIR("A")="Start Time",DIR("B")="NOW"
D ^DIR
I $D(DTOUT)!(X="") S Y=$H
I $D(DUOUT)!($D(DIROUT)) S Y=-1
K DIR,DTOUT,DUOUT,DIROUT
Q Y
;
HOLD(PAGE,TIT,MARG) ;
;device is home, reached end of page
N X
S MARG=$G(MARG) S:MARG'>80 MARG=80
W !!,"Press Any Key to Continue or '^' to Quit" R X:DTIME
I '$T!(X="^") S STOP=1 Q
D NEWP1(.PAGE,TIT,MARG)
Q
;
NEWP1(PAGE,TITL,MARG) ;
Q:$G(VALM) ;IHS/ANMC/LJF 11/2/2000
;new page
;
S MARG=$G(MARG) S:MARG'>80 MARG=80
D STOPCHK^DGUTL
I $G(STOP) D STOPPED^DGUTL Q
W:PAGE>0 @IOF
S PAGE=PAGE+1
D TITLE(PAGE,TITL,MARG)
Q
;
TITLE(PG,TITL,MARG) ;
Q:$G(VALM) ;IHS/ANMC/LJF 11/2/2000
N PDATE,SCX,SCI
S MARG=$G(MARG) S:MARG'>80 MARG=80
S PDATE=$$FMTE^XLFDT(DT,"5D")
S SCI=(IOM-$L(TITL)\2) S:SCI<24 SCI=24
S SCX="Printed on: "_PDATE
S $E(SCX,SCI)=TITL
S $E(SCX,(IOM-6-$L(PG)))="Page: "_PG
W SCX,!
Q
;
CLOSE ;close device
D:$E(IOST)'="C" ^%ZISC
Q
;
OPEN ;opens device
IF IOST?1"C-".E D Q ;%zis has already been called via $$pdevice
.W @IOF
D ^%ZIS
Q:POP
U IO
Q
;
NODATA(TITL) ;
;no data to print
;returns 1
;D OPEN ;IHS/ANMC/LJF 11/1/2000
I '$G(VALM) D OPEN ;IHS/ANMC/LJF 11/1/2000
D TITLE(1,TITL)
W !,"No data to report"
D CLOSE
Q 1
;
HELP W:'$D(VAUTNA) !,"ENTER:",!?5,"- A or ALL for all ",VAUTSTR,"s, or"
W:($D(VAUTTN))&(VAUTSTR="TEAM") !?5,"- N or NOT for not assigned to a team or"
W:($D(VAUTPO))&(VAUTSTR="PRACTITIONER") !?5,"- N or NONE or NOT for not assigned to a Practitioner"
W !?5,"- Select individual "_VAUTSTR W:'$D(VAUTPO) " -- limit 20"
W !?5,"Imprecise selections will yield an additional prompt."
I $O(@VAUTVB@(0))]"" W !?5,"- An entry preceeded by a minus [-] sign to remove entry from list."
I $O(@VAUTVB@(0))]"" W !,"NOTE, you have already selected:" S VAJ=0 F VAJ1=0:0 S VAJ=$O(@VAUTVB@(VAJ)) Q:VAJ="" W !?8,$S(VAUTNI=1:VAJ,1:@VAUTVB@(VAJ))
Q
;
CONV(ORIGA,NEWA) ;
;ORIGA - original array - name(ien)=data
;NEWA - new array - name(n)=ien^data
;
N ENT,CNT
S ENT=0,CNT=0
S NEWA=ORIGA
F S ENT=$O(ORIGA(ENT)) Q:ENT=""!(ENT'?.N) D
.S CNT=CNT+1
.S NEWA(CNT)=ENT_"^"_ORIGA(ENT)
Q
SCRPU3 ;ALB/CMM - GENERIC UTILITIES ; 9/26/05 8:50am
+1 ;;5.3;Scheduling;**41,45,52,140,181,177,432,433,346,1015**;AUG 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 11/01/2000 bypass %ZIS call if using list template
+3 ; 11/02/2000 added checks for list template
+4 ;
ELIG(DFN) ;
+1 ;Gets Primary Eligibility
+2 NEW PRIM
+3 IF '$DATA(^DPT(DFN,.36))
QUIT 0
+4 IF '$DATA(^DIC(8,+$PIECE(^DPT(DFN,.36),"^"),0))
QUIT 0
+5 SET PRIM=$PIECE($GET(^DIC(8,$PIECE($GET(^DPT(DFN,.36)),"^"),0)),"^",9)
+6 ;MAS Primary Eligibility Code
+7 SET PRIM=$PIECE($GET(^DIC(8.1,PRIM,0)),"^")
+8 ;
+9 SET PRIM=$TRANSLATE(PRIM,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+10 IF PRIM="NON-SERVICE CONNECTED"
SET PRIM="NSC"
+11 IF PRIM["SERVICE CONNECTED"
SET PRIM=$PIECE(PRIM,"SERVICE CONNECTED")_"SC"_$PIECE(PRIM,"SERVICE CONNECTED",2,999)
+12 IF PRIM["LESS THAN"
SET PRIM=$PIECE(PRIM,"LESS THAN")_"<"_$PIECE(PRIM,"LESS THAN",2,999)
+13 IF PRIM[" TO "
SET PRIM=$PIECE(PRIM," TO ")_"-"_$PIECE(PRIM," TO ",2,999)
+14 IF PRIM["%"
SET PRIM=$TRANSLATE(PRIM,"%","")
+15 SET PRIM=$EXTRACT(PRIM,1,9)
+16 QUIT PRIM
+17 ;
GETNEXT(DFN,CLN) ;
+1 ;Get next appointment for patient (DFN) at Clinic (CLN)
+2 ;Returning the date in 00/00/0000 format
+3 NEW NEXT,APPT,FOUND
+4 ;
+5 NEW SDARRAY,SDCOUNT,SDDATE,SDAPPT,SDSTATUS,%
+6 ; Tell SDAPI that we want only the next appointment based on:
+7 ; Date SDARRAY(1)=Today's Date;
+8 ; Clinic SDARRAY(2)=CLN
+9 ; Patient SDARRAY(4)=DFN
+10 ; Status SDARRAY(3)="R;I;NS;NSR;NT"
+11 ; KEPT/INPATIENT/NOSHOW/NOSHOWRESCHED/NOACTIONTAKEN
+12 ; and that we want to have field 3 (appt status) returned
+13 ; SDARRAY("FLDS")="3"
+14 ; DATA will be returned in ^TMP($J,"SDAMA301",DFN,CLN,SDDATE)
+15 ;
+16 SET FOUND=0
SET NEXT=""
+17 IF $GET(CLN)=""!($GET(DFN)="")
QUIT NEXT
+18 DO NOW^%DTC
SET SDARRAY(1)=$PIECE(%,".",1)_";"
+19 SET SDARRAY(2)=CLN
SET SDARRAY(3)="R;I;NS;NSR;NT"
SET SDARRAY(4)=DFN
SET SDARRAY("FLDS")="3"
SET SDARRAY("MAX")=1
+20 SET SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY)
+21 IF SDCOUNT>0
SET SDDATE=""
SET SDDATE=$ORDER(^TMP($JOB,"SDAMA301",DFN,CLN,SDDATE))
Begin DoDot:1
+22 SET NEXT=$TRANSLATE($$FMTE^XLFDT(SDDATE,"5DF")," ","0")
End DoDot:1
+23 ;do processing for errors
IF SDCOUNT<0
Begin DoDot:1
+24 ; None to do in this case -- return null
+25 QUIT
End DoDot:1
+26 ; when finished with all processing, kill SDAPI output array
+27 KILL ^TMP($JOB,"SDAMA301")
+28 QUIT NEXT
+29 ;
GETLAST(DFN,CLN) ;
+1 ;Get last appointment for patient (DFN) at Clinic (CLN)
+2 ;Returning the date in 00/00/0000 format
+3 NEW LAST,APPT,FOUND,STATUS
+4 NEW SDARRAY,SDCOUNT,SDDATE,SDAPPT,SDSTATUS,%
+5 ; Tell SDAPI that we want only the next appointment based on:
+6 ; Date SDARRAY(1)=;Today's Date
+7 ; Clinic SDARRAY(2)=CLN
+8 ; Patient SDARRAY(4)=DFN
+9 ; Status SDARRAY(3)="R;I;NT"
+10 ; MAX SDARRAY("MAX")=-1
+11 ; and that we want to have field 3 (appt status) returned
+12 ; SDARRAY("FLDS")="3"
+13 ; DATA will be returned in ^TMP($J,"SDAMA301",DFN,CLN,SDDATE)
+14 ;
+15 SET FOUND=0
SET LAST=""
+16 IF $GET(CLN)=""!($GET(DFN)="")
QUIT LAST
+17 DO NOW^%DTC
SET SDARRAY(1)=";"_$PIECE(%,".",1)
+18 SET SDARRAY(2)=CLN
SET SDARRAY(3)="R;I;NT"
SET SDARRAY(4)=DFN
SET SDARRAY("MAX")=-1
+19 SET SDARRAY("FLDS")="3"
+20 SET SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY)
+21 IF SDCOUNT>0
SET SDDATE=""
Begin DoDot:1
+22 SET SDDATE=$ORDER(^TMP($JOB,"SDAMA301",DFN,CLN,SDDATE))
+23 SET LAST=$TRANSLATE($$FMTE^XLFDT(SDDATE,"5DF")," ","0")
End DoDot:1
+24 ;do processing for errors
IF SDCOUNT<0
Begin DoDot:1
+25 ; None to do in this case
QUIT
End DoDot:1
+26 ; when finished with all processing, kill SDAPI output array
+27 KILL ^TMP($JOB,"SDAMA301")
+28 QUIT LAST
+29 ;
PDEVICE() ;
+1 ;Generic Printer Call
+2 NEW TION,POP
+3 SET %ZIS="QN"
DO ^%ZIS
KILL %ZIS
IF POP!(ION="^")
QUIT -1
+4 SET TION=ION
+5 IF $DATA(IO("Q"))
SET TION="Q;"_TION
+6 QUIT TION_"^"_IOST
+7 ;
GETTIME() ;
+1 ;Prompt for Queue Time
+2 NEW X,Y
+3 SET DIR(0)="D^::RFE"
SET DIR("A")="Start Time"
SET DIR("B")="NOW"
+4 DO ^DIR
+5 IF $DATA(DTOUT)!(X="")
SET Y=$HOROLOG
+6 IF $DATA(DUOUT)!($DATA(DIROUT))
SET Y=-1
+7 KILL DIR,DTOUT,DUOUT,DIROUT
+8 QUIT Y
+9 ;
HOLD(PAGE,TIT,MARG) ;
+1 ;device is home, reached end of page
+2 NEW X
+3 SET MARG=$GET(MARG)
IF MARG'>80
SET MARG=80
+4 WRITE !!,"Press Any Key to Continue or '^' to Quit"
READ X:DTIME
+5 IF '$TEST!(X="^")
SET STOP=1
QUIT
+6 DO NEWP1(.PAGE,TIT,MARG)
+7 QUIT
+8 ;
NEWP1(PAGE,TITL,MARG) ;
+1 ;IHS/ANMC/LJF 11/2/2000
IF $GET(VALM)
QUIT
+2 ;new page
+3 ;
+4 SET MARG=$GET(MARG)
IF MARG'>80
SET MARG=80
+5 DO STOPCHK^DGUTL
+6 IF $GET(STOP)
DO STOPPED^DGUTL
QUIT
+7 IF PAGE>0
WRITE @IOF
+8 SET PAGE=PAGE+1
+9 DO TITLE(PAGE,TITL,MARG)
+10 QUIT
+11 ;
TITLE(PG,TITL,MARG) ;
+1 ;IHS/ANMC/LJF 11/2/2000
IF $GET(VALM)
QUIT
+2 NEW PDATE,SCX,SCI
+3 SET MARG=$GET(MARG)
IF MARG'>80
SET MARG=80
+4 SET PDATE=$$FMTE^XLFDT(DT,"5D")
+5 SET SCI=(IOM-$LENGTH(TITL)\2)
IF SCI<24
SET SCI=24
+6 SET SCX="Printed on: "_PDATE
+7 SET $EXTRACT(SCX,SCI)=TITL
+8 SET $EXTRACT(SCX,(IOM-6-$LENGTH(PG)))="Page: "_PG
+9 WRITE SCX,!
+10 QUIT
+11 ;
CLOSE ;close device
+1 IF $EXTRACT(IOST)'="C"
DO ^%ZISC
+2 QUIT
+3 ;
OPEN ;opens device
+1 ;%zis has already been called via $$pdevice
IF IOST?1"C-".E
Begin DoDot:1
+2 WRITE @IOF
End DoDot:1
QUIT
+3 DO ^%ZIS
+4 IF POP
QUIT
+5 USE IO
+6 QUIT
+7 ;
NODATA(TITL) ;
+1 ;no data to print
+2 ;returns 1
+3 ;D OPEN ;IHS/ANMC/LJF 11/1/2000
+4 ;IHS/ANMC/LJF 11/1/2000
IF '$GET(VALM)
DO OPEN
+5 DO TITLE(1,TITL)
+6 WRITE !,"No data to report"
+7 DO CLOSE
+8 QUIT 1
+9 ;
HELP IF '$DATA(VAUTNA)
WRITE !,"ENTER:",!?5,"- A or ALL for all ",VAUTSTR,"s, or"
+1 IF ($DATA(VAUTTN))&(VAUTSTR="TEAM")
WRITE !?5,"- N or NOT for not assigned to a team or"
+2 IF ($DATA(VAUTPO))&(VAUTSTR="PRACTITIONER")
WRITE !?5,"- N or NONE or NOT for not assigned to a Practitioner"
+3 WRITE !?5,"- Select individual "_VAUTSTR
IF '$DATA(VAUTPO)
WRITE " -- limit 20"
+4 WRITE !?5,"Imprecise selections will yield an additional prompt."
+5 IF $ORDER(@VAUTVB@(0))]""
WRITE !?5,"- An entry preceeded by a minus [-] sign to remove entry from list."
+6 IF $ORDER(@VAUTVB@(0))]""
WRITE !,"NOTE, you have already selected:"
SET VAJ=0
FOR VAJ1=0:0
SET VAJ=$ORDER(@VAUTVB@(VAJ))
IF VAJ=""
QUIT
WRITE !?8,$SELECT(VAUTNI=1:VAJ,1:@VAUTVB@(VAJ))
+7 QUIT
+8 ;
CONV(ORIGA,NEWA) ;
+1 ;ORIGA - original array - name(ien)=data
+2 ;NEWA - new array - name(n)=ien^data
+3 ;
+4 NEW ENT,CNT
+5 SET ENT=0
SET CNT=0
+6 SET NEWA=ORIGA
+7 FOR
SET ENT=$ORDER(ORIGA(ENT))
IF ENT=""!(ENT'?.N)
QUIT
Begin DoDot:1
+8 SET CNT=CNT+1
+9 SET NEWA(CNT)=ENT_"^"_ORIGA(ENT)
End DoDot:1
+10 QUIT
