- SCRPU3 ;ALB/CMM - GENERIC UTILITIES ; 9/26/05 8:50am
- ;;5.3;Scheduling;**41,45,52,140,181,177,432,433,346**;AUG 13, 1993
- ;
- 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) ;
- ;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) ;
- 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
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPU3 5399 printed Jan 18, 2025@03:44:18 Page 2
- SCRPU3 ;ALB/CMM - GENERIC UTILITIES ; 9/26/05 8:50am
- +1 ;;5.3;Scheduling;**41,45,52,140,181,177,432,433,346**;AUG 13, 1993
- +2 ;
- 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 ;new page
- +2 ;
- +3 SET MARG=$GET(MARG)
- if MARG'>80
- SET MARG=80
- +4 DO STOPCHK^DGUTL
- +5 IF $GET(STOP)
- DO STOPPED^DGUTL
- QUIT
- +6 if PAGE>0
- WRITE @IOF
- +7 SET PAGE=PAGE+1
- +8 DO TITLE(PAGE,TITL,MARG)
- +9 QUIT
- +10 ;
- TITLE(PG,TITL,MARG) ;
- +1 NEW PDATE,SCX,SCI
- +2 SET MARG=$GET(MARG)
- if MARG'>80
- SET MARG=80
- +3 SET PDATE=$$FMTE^XLFDT(DT,"5D")
- +4 SET SCI=(IOM-$LENGTH(TITL)\2)
- if SCI<24
- SET SCI=24
- +5 SET SCX="Printed on: "_PDATE
- +6 SET $EXTRACT(SCX,SCI)=TITL
- +7 SET $EXTRACT(SCX,(IOM-6-$LENGTH(PG)))="Page: "_PG
- +8 WRITE SCX,!
- +9 QUIT
- +10 ;
- 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 DO OPEN
- +4 DO TITLE(1,TITL)
- +5 WRITE !,"No data to report"
- +6 DO CLOSE
- +7 QUIT 1
- +8 ;
- 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