SDTMPUT4 ;BAH/DRF - ADVANCED CLINIC SEARCH REPORT;Apr 21, 2025
;;5.3;Scheduling;**911**;Aug 13, 1993;Build 15
;;Per VHA Directive 6402, this routine should not be modified
;
; Reference to ^ECX(728.44 in #7340
Q
;
BEGIN ;Ask for search criteria
W #,"ADVANCED CLINIC SEARCH",!!
K ^TMP("SDTMPUT4",$J)
D ACT I Y="^" D END Q
D CLINIC I Y="^" D END Q
D DEFPROV I X="^" D END Q
D PROVIDER I X="^" D END Q
D STOPCODEX I X="^" D END Q
D CHAR4 I X="^" D END Q
D DIV I X="^" D END Q
;
IO ;Ask IO device
W !!,"FOR PROPER FORMATTING, THIS REPORT SHOULD BE PRINTED TO A 132 COLUMN DEVICE OR TERMINAL"
S %ZIS="PM" D ^%ZIS I POP D END Q
;
LOOP ;Loop through selected clinics
S CNT=0,FND=0,PGNO=0,INACT=0
S CLNAM="" F S CLNAM=$O(^TMP("SDTMPUT4",$J,"C",CLNAM)) Q:CLNAM="" D
. S CL=0 F S CL=$O(^TMP("SDTMPUT4",$J,"C",CLNAM,CL)) Q:'CL D
.. S IN=$G(^SC(CL,"I"))
.. I $P(IN,U,1)>0,+$P(IN,U,2)=0,^TMP("SDTMPUT4",$J,"ACT")="A" Q ;Eliminate inactive clinics
.. I +$P(IN,U,1)=0!(+$P(IN,U,1)>0&(+$P(IN,U,2)>0)),^TMP("SDTMPUT4",$J,"ACT")="I" Q ;Eliminate active clinics
.. S NODE0=$G(^SC(CL,0)),CLSTC=$P(NODE0,U,7),CLCRSC=$P(NODE0,U,18),DIV=$P(NODE0,U,15),DP=$P(NODE0,U,13),CLCHAR4=$$CHAR4^SDESUTIL($P(NODE0,U,1))
.. S INST="" I $G(DIV) S INST=$P($G(^DG(40.8,DIV,0)),U,7)
.. S SDDIS=0 I $P($G(^SC(CL,"PA")),U,3)="Y" S SDDIS=1
.. S DPR="" I +DP S DPR=$P(^VA(200,DP,0),U,1)
.. I $D(^TMP("SDTMPUT4",$J,"DIV")),DIV'=$G(^TMP("SDTMPUT4",$J,"DIV")) Q ;Eliminate non-matching divisions
.. I $D(^TMP("SDTMPUT4",$J,"DP")) I $$DPRVMTCH(DP)=0 Q ;Eliminate non-matching default provider
.. I $D(^TMP("SDTMPUT4",$J,"P")) I '$$PROVMATCH(CL) Q ;Eliminate non-matching provider
.. I $D(^TMP("SDTMPUT4",$J,"SCP")) I $$SCPCHK()=0 Q ;Eliminate non-matching stop code pair
.. I $D(^TMP("SDTMPUT4",$J,"SC")) I $$SCCHK()=0 Q ;Eliminate non-matching stop code
.. I $D(^TMP("SDTMPUT4",$J,"CHAR4")) I CLCHAR4="" Q ;Eliminate non-matching CHAR4
.. I $D(^TMP("SDTMPUT4",$J,"CHAR4")) I '$D(^TMP("SDTMPUT4",$J,"CHAR4",CLCHAR4)) Q ;Eliminate non-matching CHAR4
.. D PRVARR
.. D LINE
I 'FND D HEADER W !!,"NO CLINICS MEETING THE CRITERIA WERE FOUND",!
I CNT W !!,CNT," CLINIC" W:CNT>1 "S" W " TOTAL (",INACT," INACTIVE, ",CNT-INACT," ACTIVE)",!
W !,"** END **"
G END
;
N I,CRIT,DP,P,SC0,SCP,SCT,SCPAIR
W #
S PGNO=PGNO+1
W ?1,"ADVANCED CLINIC SEARCH",?71,"DATE: ",$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),?122,"PAGE: ",PGNO,!
W ?1,"FLAGS: *=INACTIVE CLINIC, +=DISPLAY APPT TO PATIENTS, S=INACTIVE STOP CODE, C=INACTIVE CREDIT STOP CODE",!
W ?1,$S($G(^TMP("SDTMPUT4",$J,"ACT"))="B":"BOTH ACTIVE AND *INACTIVE CLINICS",$G(^TMP("SDTMPUT4",$J,"ACT"))="I":"*INACTIVE CLINICS",1:"ACTIVE CLINICS")
W " "
S I="" F S I=$O(^TMP("SDTMPUT4",$J,"CRI",I)) W:'I ! Q:'I D
. S CRIT=^TMP("SDTMPUT4",$J,"CRI",I)
. I CRIT="ALL" W ?1,"ALL CLINICS" Q
. I I>1 W " and "
. I CRIT["[" W "CLINICS CONTAINING """_$P(CRIT,"[",2)_""""
. I CRIT'["[" W "CLINICS BEGINNING WITH """_CRIT_""""
I $D(^TMP("SDTMPUT4",$J,"DP")) D W " DEFAULT PROVIDER: ",DP,!
. S DP=""
. S I=0 F S I=$O(^TMP("SDTMPUT4",$J,"DP",I)) Q:'I S DP=DP_$S(DP="":$P(^VA(200,I,0),U),1:", "_$P(^VA(200,I,0),U))
I $D(^TMP("SDTMPUT4",$J,"P")) D W " PROVIDER: ",P,!
. S P=""
. S I=0 F S I=$O(^TMP("SDTMPUT4",$J,"P",I)) Q:'I S P=P_$S(P="":$P(^VA(200,I,0),U),1:", "_$P(^VA(200,I,0),U))
I $D(^TMP("SDTMPUT4",$J,"SC")) D W " STOP CODE: ",SC,!
. S SC=""
. S I=0 F S I=$O(^TMP("SDTMPUT4",$J,"SC",I)) Q:'I D
.. S SCT=^TMP("SDTMPUT4",$J,"SC",I),SC0=$G(^DIC(40.7,I,0)),SC=SC_$S(SC="":"",1:", ")_$P(SC0,U,2)_"-"_$P(SC0,U,1)_"("_SCT_")"_$S($P(SC0,U,3):" (Inactive)",1:"")
I $D(^TMP("SDTMPUT4",$J,"SCP")) D W " STOP CODE PAIR: ",SCPAIR,!
. S SCP=0,SCP=$O(^TMP("SDTMPUT4",$J,"SCP",SCP))
. S SC=$E(SCP,1,3),SC0=$G(^DIC(40.7,SC,0)),SCPAIR=$P(SC0,U,2)_"-"_$P(SC0,U,1)_$S($P(SC0,U,3):" (Inactive)",1:"")
. S SC=$E(SCP,4,7),SC0=$G(^DIC(40.7,SC,0)),SCPAIR=SCPAIR_$S(SC="":"",1:", ")_$P(SC0,U,2)_"-"_$P(SC0,U,1)_$S($P(SC0,U,3):" (Inactive)",1:"")
I $D(^TMP("SDTMPUT4",$J,"CHAR4")) D W " CHAR4: ",CHAR4,!
. S CHAR4=""
. S I="" F S I=$O(^TMP("SDTMPUT4",$J,"CHAR4",I)) Q:I="" S CHAR4=CHAR4_$S(CHAR4="":"",1:", ")_I_"-"_$P(^ECX(728.441,$O(^ECX(728.441,"B",I,0)),0),U,2)
S SDIV=$G(^TMP("SDTMPUT4",$J,"DIV"))
W ?1,"DIVISION: ",$S(SDIV="":"ALL",1:$P($G(^DG(40.8,SDIV,0)),U,1)),!
W ?1,"Clinic Name",?36,"IEN",?41,"CHAR4",?47,"SC#/CS#",?55,"Station",?63,"Provider (!Default Flag)",?89,"Default Provider",?116,"Updated",?127,"Flags",!
W ?1,"--------------------------------",?34,"------",?41,"-----",?47,"-------",?55,"-------",?63,"-------------------------",?89,"--------------------------",?116,"----------",?127,"-----",!
Q
;
LINE ;Write a single clinic record
N SDFLG,CLSTD,CLCRSD,CLSTI,CLCRSI
S FND=FND+1,CNT=CNT+1,SDFLG=" ",CLSTD="",CLCRSD="",CLSTI="",CLCRSI=""
I FND#60=1 D HEADER
I $P(IN,U,1)>0,+$P(IN,U,2)=0 S $E(SDFLG,1)="*",INACT=INACT+1
I SDDIS S $E(SDFLG,2)="+"
I CLSTC]"" S CLSTD=$P($G(^DIC(40.7,CLSTC,0)),U,2),CLSTI=$P($G(^DIC(40.7,CLSTC,0)),U,3)
I CLSTI S $E(SDFLG,3)="S"
I CLSTD="" S CLSTD=" "
I CLCRSC]"" S CLCRSD=$P($G(^DIC(40.7,CLCRSC,0)),U,2),CLCRSI=$P($G(^DIC(40.7,CLCRSC,0)),U,3)
I CLCRSD="" S CLCRSD=" "
I CLCRSI S $E(SDFLG,4)="C"
N X,XL,CLIN S X=" "_CL,XL=$L(X),CLIN=$E(X,XL-5,XL)
W ?1,CLNAM,?34,CLIN,?41,CLCHAR4,?47,CLSTD,"/",CLCRSD,?55,$$GET1^DIQ(4,INST_",",99,"E"),?63,$E($G(PRV(1)),1,25),?89,$E(DPR,1,25),?116,$P($$AUDIT^SDTMPUT0(+CL),"@",1),?127,SDFLG,!
I PRV>1 F K=2:1:PRV W ?63,PRV(K),! S FND=FND+1 D:FND#60=1 HEADER
Q
;
END ;Clean up and Quit
K ^TMP("SDTMPUT4",$J)
K %ZIS,C,CHAR4,CL,CLCHAR4,CLCRSC,CLNAM,CLSTC,CNT,CRIT,CRITCNT,DIC,DIR,DIV,DP,DPR,FND,I,IN,INACT,INST,K,NODE0,PGNO,POP,PRNO,PRQTY,PRV,SC,SDDIS,SDIV,X,Y
Q
;
ACT ;View active, inactive or both clinics
K DIR,X,Y
S DIR(0)="SA^A:ACTIVE;I:INACTIVE;B:BOTH^",DIR("B")="B"
S DIR("A")="List which clinics - (A)ctive, (I)nactive or (B)oth ? "
D ^DIR
S ^TMP("SDTMPUT4",$J,"ACT")=Y
Q
;
DIV ;Ask DIVISION
K DIC,X,Y
S DIC="^DG(40.8,",DIC(0)="AEMQZ" ;,DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))"
S DIC("A")="Select DIVISION: ALL// " D ^DIC K DIC("S"),DIC("A") Q:"^"[X I +Y'>0 G:+Y<0 DIV
I X="^" Q
S ^TMP("SDTMPUT4",$J,"DIV")=$P(Y,U,1)
Q
;
CLINIC ;Ask CLINIC
K C,CRIT,CRITCNT,D,DIR,FND,X,Y
S DIR(0)="FO",DIR("A")="Select CLINIC NAME or ALL",CRITCNT="",CRITCNT=+$O(^TMP("SDTMPUT4",$J,"CRI",CRITCNT),-1)
S DIR("?")=" "
S DIR("?",1)="Enter a partial clinic name to find all clinics beginning with"
S DIR("?",2)="that phrase. Use the left bracket ([) to find any clinics that"
S DIR("?",3)="contains that phrase anywhere in their name. Enter ALL to include"
S DIR("?",4)="all clinics. If you do not enter anything, ALL will be assumed."
S DIR("?",5)="You may enter more than one clinic name on separate lines."
D ^DIR
I X="",$D(^TMP("SDTMPUT4",$J,"C")) Q
I X="",'$D(^TMP("SDTMPUT4",$J,"C")) S X="ALL" W "ALL"
I X="^" Q
S CRIT=X ;Save criteria for report header
I X="ALL" D Q
. K ^TMP("SDTMPUT4",$J,"C") ;All overwrites previous selections
. S FND="" F I=1:1 S FND=$O(^SC("B",FND)) Q:FND="" S C=0 F S C=$O(^SC("B",FND,C)) Q:'C S ^TMP("SDTMPUT4",$J,"C",FND,C)=""
. S ^TMP("SDTMPUT4",$J,"CRI",1)="ALL"
S D=X
S FND=$O(^SC("B",D)),CNT=0
I X'["[",$E(FND,1,$L(D))'=D W " NOT FOUND",! G CLINIC
I X["[" D
. S FND="" F I=1:1 S FND=$O(^SC("B",FND)) Q:FND="" I FND[$P(X,"[",2) S C=0 F S C=$O(^SC("B",FND,C)) Q:'C S ^TMP("SDTMPUT4",$J,"C",FND,C)="",CNT=CNT+1
. W " ",CNT," CLINICS FOUND"
. S CRITCNT=CRITCNT+1,^TMP("SDTMPUT4",$J,"CRI",CRITCNT)=CRIT
I X]"",X'["[" D
. F I=1:1 S FND=$O(^SC("B",FND)) Q:$E(FND,1,$L(D))'=D S C=0 F S C=$O(^SC("B",FND,C)) Q:'C S ^TMP("SDTMPUT4",$J,"C",FND,C)="",CNT=CNT+1
. W " ",CNT," CLINICS FOUND"
. S CRITCNT=CRITCNT+1,^TMP("SDTMPUT4",$J,"CRI",CRITCNT)=CRIT
G CLINIC
Q
;
CHAR4 ;Ask CHAR4
K DIC,X,Y
S DIC="^ECX(728.441,",DIC(0)="AEMQZ"
S DIC("A")="Select CHAR4: " D ^DIC K DIC("S"),DIC("A") Q:"^"[X I +Y'>0 G CHAR4
I X="^" Q
W " ",$P(Y(0),U,2),!
S ^TMP("SDTMPUT4",$J,"CHAR4",$P(Y,U,2))=""
G CHAR4
Q
;
DEFPROV ;Ask DEFAULT PROVIDER
K DIC,X,Y
S DIC="^VA(200,",DIC(0)="AEMQZ"
S DIC("A")="Select DEFAULT PROVIDER: " D ^DIC K DIC("S"),DIC("A") Q:"^"[X I +Y'>0 G:+Y<0 DEFPROV
I X="" Q
I X="^" Q
I '$D(^SC("AVADPR",$P(Y,U,1))) W " This person is not the default provider for any existing clinic",! G DEFPROV
S ^TMP("SDTMPUT4",$J,"DP",$P(Y,U,1))=""
G DEFPROV
Q
;
PROVIDER ;Ask PROVIDER From provider multiple
K DIC,X,Y
S DIC="^VA(200,",DIC(0)="AEMQZ"
S DIC("A")="Select PROVIDER: " D ^DIC K DIC("S"),DIC("A") Q:"^"[X G:+Y<0 PROVIDER
I X="" Q
I X="^" Q
S ^TMP("SDTMPUT4",$J,"P",$P(Y,U,1))=""
G PROVIDER
Q
;
PROVMATCH(CLINIC) ;Does clinic match search provider(s)?
N MATCH,PCNT,PRDUZ,PRNO,PRQTY
S PRQTY=+$P($G(^SC(CLINIC,"PR",0)),U,4) I PRQTY=0 Q 0
S PCNT=0,MATCH=0
F PRNO=1:1:PRQTY D
. S PCNT=$O(^SC(CLINIC,"PR",PCNT))
. S PRDUZ=$P(^SC(CLINIC,"PR",PCNT,0),U,1)
. I $D(^TMP("SDTMPUT4",$J,"P",PRDUZ)) S MATCH=1 Q
Q MATCH
;
PRVARR ;Create provider array
K PRV
N PCNT,PRDEF,PRDUZ,PRNAM,PRQTY
S PRQTY=$P($G(^SC(CL,"PR",0)),U,4) I PRQTY=0 S PRV=0 Q
S PCNT=0
F PRNO=1:1:PRQTY D
. S PCNT=$O(^SC(CL,"PR",PCNT))
. S PRDUZ=$P(^SC(CL,"PR",PCNT,0),U,1),PRDEF=+$P(^SC(CL,"PR",PCNT,0),U,2),PRNAM=$P($G(^VA(200,PRDUZ,0)),U,1)
. S PRV(PRNO)=PRNAM_$S(PRDEF:"!",1:"")
S PRV=PRQTY
Q
;
DPRVMTCH(DP) ;Does clinic match default provider(s)
N MATCH,SDDP
S MATCH=0
I DP="" Q MATCH
S SDDP="" F S SDDP=$O(^TMP("SDTMPUT4",$J,"DP",SDDP)) Q:SDDP="" I SDDP=DP S MATCH=1 Q
Q MATCH
;
SCTYPE ;Where do you want to search for STOP CODE?
S DIR(0)="FO",DIR("A")="Select (S)TOP CODE, (C)REDIT STOP CODE or (B)OTH"
S DIR("?")=" "
S DIR("?",1)="Enter S to check for Stop Code in the primary position."
S DIR("?",2)="Enter C to check for a Stop Code in Credit Stop Code field"
S DIR("?",3)="Enter B to check for a Stop Code in both fields."
D ^DIR
I X="" G SCTYPE
I X="s" S X="S"
I X="c" S X="C"
I X="b" S X="B"
I X'="S",X'="C",X'="B" W " Invalid choice" G SCTYPE
Q
;
SCCHK() ;Individual STOP CODE check
N MATCH
S MATCH=0
I 'CLSTC,'CLCRSC Q MATCH
I CLSTC,$D(^TMP("SDTMPUT4",$J,"SC",CLSTC)),"BS"[$G(^TMP("SDTMPUT4",$J,"SC",CLSTC)) S MATCH=1
I CLCRSC,$D(^TMP("SDTMPUT4",$J,"SC",CLCRSC)),"BC"[$G(^TMP("SDTMPUT4",$J,"SC",CLCRSC)) S MATCH=1
Q MATCH
;
SCPCHK() ;Pair STOP CODE check
N SCP,CLSTP,CLCRSP,MATCH
S MATCH=0
I 'CLSTC Q MATCH
I 'CLCRSC Q MATCH
S SCP="",SCP=$O(^TMP("SDTMPUT4",$J,"SCP",SCP))
S CLSTP=$E(SCP,1,3),CLCRSP=$E(SCP,4,6)
I CLSTP=CLSTC,CLCRSP=CLCRSC S MATCH=1
Q MATCH
;
STOPCODEX ;Ask STOP CODE
N ERROR,SCP
S DIR(0)="FO"
S DIR("A")=$S($D(^TMP("SDTMPUT4",$J,"SC")):"Select STOP CODE",1:"Select STOP CODE or PAIR")
S DIR("?")=" "
S DIR("?",1)="Enter a stop code or stop code pair. Stop code pairs must be "
S DIR("?",2)="entered one per report with no other stop codes or pairs entered."
S DIR("?",3)="Stop code pairs are entered as a 6 digit number with no slash or other"
S DIR("?",4)="separator. Individual stop codes can be entered in multiples one at a"
S DIR("?",5)="time on separate lines. You can search for individual stop codes as the"
S DIR("?",6)="primary stop code, credit stop code or both."
D ^DIR
I X="",$D(^TMP("SDTMPUT4",$J,"SC")) Q
I X="" Q
I X="^" Q
I X'?2.6N W " INVALID STOP CODE" G STOPCODEX
I X?2.3N D
. S ERROR=0,ERROR=$$SCLU(X,0) I 'ERROR S ^TMP("SDTMPUT4",$J,"SC",SC)=X
I X?6N D
. I $D(^TMP("SDTMPUT4",$J,"SC")) W ?34,"STOP CODE PAIRS MUST BE ENTERED ALONE",! Q
. S ERROR=0
. S ERROR=ERROR+$$SCLU($E(X,1,3),1)
. I 'ERROR S $E(SCP,1,3)=SC
. S ERROR=ERROR+$$SCLU($E(X,4,6),1)
. I 'ERROR S $E(SCP,4,6)=SC
. I ERROR W ?34,"INVALID PAIR",! Q
. S ^TMP("SDTMPUT4",$J,"SCP",SCP)=""
I $D(^TMP("SDTMPUT4",$J,"SCP")) Q
G STOPCODEX
Q
SCLU(CODE,PAIR) ;Return SCERR=1 error, SCERR=0 no error
N SC0
S CODE=+CODE
I '$D(^DIC(40.7,"C",CODE)) W ?34,"NOT FOUND",! Q 1
I $D(^DIC(40.7,"C",CODE)) S SC="",SC=$O(^DIC(40.7,"C",CODE,SC))
S SC0=^DIC(40.7,SC,0)
W ?34,$P(SC0,U,2)," - ",$P(SC0,U,1)
I $P(SC0,U,3) W " (INACTIVE)"
I 'PAIR D SCTYPE
W !
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDTMPUT4 12388 printed Jan 29, 2026@16:01:15 Page 2
SDTMPUT4 ;BAH/DRF - ADVANCED CLINIC SEARCH REPORT;Apr 21, 2025
+1 ;;5.3;Scheduling;**911**;Aug 13, 1993;Build 15
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ; Reference to ^ECX(728.44 in #7340
+5 QUIT
+6 ;
BEGIN ;Ask for search criteria
+1 WRITE #,"ADVANCED CLINIC SEARCH",!!
+2 KILL ^TMP("SDTMPUT4",$JOB)
+3 DO ACT
IF Y="^"
DO END
QUIT
+4 DO CLINIC
IF Y="^"
DO END
QUIT
+5 DO DEFPROV
IF X="^"
DO END
QUIT
+6 DO PROVIDER
IF X="^"
DO END
QUIT
+7 DO STOPCODEX
IF X="^"
DO END
QUIT
+8 DO CHAR4
IF X="^"
DO END
QUIT
+9 DO DIV
IF X="^"
DO END
QUIT
+10 ;
IO ;Ask IO device
+1 WRITE !!,"FOR PROPER FORMATTING, THIS REPORT SHOULD BE PRINTED TO A 132 COLUMN DEVICE OR TERMINAL"
+2 SET %ZIS="PM"
DO ^%ZIS
IF POP
DO END
QUIT
+3 ;
LOOP ;Loop through selected clinics
+1 SET CNT=0
SET FND=0
SET PGNO=0
SET INACT=0
+2 SET CLNAM=""
FOR
SET CLNAM=$ORDER(^TMP("SDTMPUT4",$JOB,"C",CLNAM))
if CLNAM=""
QUIT
Begin DoDot:1
+3 SET CL=0
FOR
SET CL=$ORDER(^TMP("SDTMPUT4",$JOB,"C",CLNAM,CL))
if 'CL
QUIT
Begin DoDot:2
+4 SET IN=$GET(^SC(CL,"I"))
+5 ;Eliminate inactive clinics
IF $PIECE(IN,U,1)>0
IF +$PIECE(IN,U,2)=0
IF ^TMP("SDTMPUT4",$JOB,"ACT")="A"
QUIT
+6 ;Eliminate active clinics
IF +$PIECE(IN,U,1)=0!(+$PIECE(IN,U,1)>0&(+$PIECE(IN,U,2)>0))
IF ^TMP("SDTMPUT4",$JOB,"ACT")="I"
QUIT
+7 SET NODE0=$GET(^SC(CL,0))
SET CLSTC=$PIECE(NODE0,U,7)
SET CLCRSC=$PIECE(NODE0,U,18)
SET DIV=$PIECE(NODE0,U,15)
SET DP=$PIECE(NODE0,U,13)
SET CLCHAR4=$$CHAR4^SDESUTIL($PIECE(NODE0,U,1))
+8 SET INST=""
IF $GET(DIV)
SET INST=$PIECE($GET(^DG(40.8,DIV,0)),U,7)
+9 SET SDDIS=0
IF $PIECE($GET(^SC(CL,"PA")),U,3)="Y"
SET SDDIS=1
+10 SET DPR=""
IF +DP
SET DPR=$PIECE(^VA(200,DP,0),U,1)
+11 ;Eliminate non-matching divisions
IF $DATA(^TMP("SDTMPUT4",$JOB,"DIV"))
IF DIV'=$GET(^TMP("SDTMPUT4",$JOB,"DIV"))
QUIT
+12 ;Eliminate non-matching default provider
IF $DATA(^TMP("SDTMPUT4",$JOB,"DP"))
IF $$DPRVMTCH(DP)=0
QUIT
+13 ;Eliminate non-matching provider
IF $DATA(^TMP("SDTMPUT4",$JOB,"P"))
IF '$$PROVMATCH(CL)
QUIT
+14 ;Eliminate non-matching stop code pair
IF $DATA(^TMP("SDTMPUT4",$JOB,"SCP"))
IF $$SCPCHK()=0
QUIT
+15 ;Eliminate non-matching stop code
IF $DATA(^TMP("SDTMPUT4",$JOB,"SC"))
IF $$SCCHK()=0
QUIT
+16 ;Eliminate non-matching CHAR4
IF $DATA(^TMP("SDTMPUT4",$JOB,"CHAR4"))
IF CLCHAR4=""
QUIT
+17 ;Eliminate non-matching CHAR4
IF $DATA(^TMP("SDTMPUT4",$JOB,"CHAR4"))
IF '$DATA(^TMP("SDTMPUT4",$JOB,"CHAR4",CLCHAR4))
QUIT
+18 DO PRVARR
+19 DO LINE
End DoDot:2
End DoDot:1
+20 IF 'FND
DO HEADER
WRITE !!,"NO CLINICS MEETING THE CRITERIA WERE FOUND",!
+21 IF CNT
WRITE !!,CNT," CLINIC"
if CNT>1
WRITE "S"
WRITE " TOTAL (",INACT," INACTIVE, ",CNT-INACT," ACTIVE)",!
+22 WRITE !,"** END **"
+23 GOTO END
+24 ;
+1 NEW I,CRIT,DP,P,SC0,SCP,SCT,SCPAIR
+2 WRITE #
+3 SET PGNO=PGNO+1
+4 WRITE ?1,"ADVANCED CLINIC SEARCH",?71,"DATE: ",$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3),?122,"PAGE: ",PGNO,!
+5 WRITE ?1,"FLAGS: *=INACTIVE CLINIC, +=DISPLAY APPT TO PATIENTS, S=INACTIVE STOP CODE, C=INACTIVE CREDIT STOP CODE",!
+6 WRITE ?1,$SELECT($GET(^TMP("SDTMPUT4",$JOB,"ACT"))="B":"BOTH ACTIVE AND *INACTIVE CLINICS",$GET(^TMP("SDTMPUT4",$JOB,"ACT"))="I":"*INACTIVE CLINICS",1:"ACTIVE CLINICS")
+7 WRITE " "
+8 SET I=""
FOR
SET I=$ORDER(^TMP("SDTMPUT4",$JOB,"CRI",I))
if 'I
WRITE !
if 'I
QUIT
Begin DoDot:1
+9 SET CRIT=^TMP("SDTMPUT4",$JOB,"CRI",I)
+10 IF CRIT="ALL"
WRITE ?1,"ALL CLINICS"
QUIT
+11 IF I>1
WRITE " and "
+12 IF CRIT["["
WRITE "CLINICS CONTAINING """_$PIECE(CRIT,"[",2)_""""
+13 IF CRIT'["["
WRITE "CLINICS BEGINNING WITH """_CRIT_""""
End DoDot:1
+14 IF $DATA(^TMP("SDTMPUT4",$JOB,"DP"))
Begin DoDot:1
+15 SET DP=""
+16 SET I=0
FOR
SET I=$ORDER(^TMP("SDTMPUT4",$JOB,"DP",I))
if 'I
QUIT
SET DP=DP_$SELECT(DP="":$PIECE(^VA(200,I,0),U),1:", "_$PIECE(^VA(200,I,0),U))
End DoDot:1
WRITE " DEFAULT PROVIDER: ",DP,!
+17 IF $DATA(^TMP("SDTMPUT4",$JOB,"P"))
Begin DoDot:1
+18 SET P=""
+19 SET I=0
FOR
SET I=$ORDER(^TMP("SDTMPUT4",$JOB,"P",I))
if 'I
QUIT
SET P=P_$SELECT(P="":$PIECE(^VA(200,I,0),U),1:", "_$PIECE(^VA(200,I,0),U))
End DoDot:1
WRITE " PROVIDER: ",P,!
+20 IF $DATA(^TMP("SDTMPUT4",$JOB,"SC"))
Begin DoDot:1
+21 SET SC=""
+22 SET I=0
FOR
SET I=$ORDER(^TMP("SDTMPUT4",$JOB,"SC",I))
if 'I
QUIT
Begin DoDot:2
+23 SET SCT=^TMP("SDTMPUT4",$JOB,"SC",I)
SET SC0=$GET(^DIC(40.7,I,0))
SET SC=SC_$SELECT(SC="":"",1:", ")_$PIECE(SC0,U,2)_"-"_$PIECE(SC0,U,1)_"("_SCT_")"_$SELECT($PIECE(SC0,U,3):" (Inactive)",1:"")
End DoDot:2
End DoDot:1
WRITE " STOP CODE: ",SC,!
+24 IF $DATA(^TMP("SDTMPUT4",$JOB,"SCP"))
Begin DoDot:1
+25 SET SCP=0
SET SCP=$ORDER(^TMP("SDTMPUT4",$JOB,"SCP",SCP))
+26 SET SC=$EXTRACT(SCP,1,3)
SET SC0=$GET(^DIC(40.7,SC,0))
SET SCPAIR=$PIECE(SC0,U,2)_"-"_$PIECE(SC0,U,1)_$SELECT($PIECE(SC0,U,3):" (Inactive)",1:"")
+27 SET SC=$EXTRACT(SCP,4,7)
SET SC0=$GET(^DIC(40.7,SC,0))
SET SCPAIR=SCPAIR_$SELECT(SC="":"",1:", ")_$PIECE(SC0,U,2)_"-"_$PIECE(SC0,U,1)_$SELECT($PIECE(SC0,U,3):" (Inactive)",1:"")
End DoDot:1
WRITE " STOP CODE PAIR: ",SCPAIR,!
+28 IF $DATA(^TMP("SDTMPUT4",$JOB,"CHAR4"))
Begin DoDot:1
+29 SET CHAR4=""
+30 SET I=""
FOR
SET I=$ORDER(^TMP("SDTMPUT4",$JOB,"CHAR4",I))
if I=""
QUIT
SET CHAR4=CHAR4_$SELECT(CHAR4="":"",1:", ")_I_"-"_$PIECE(^ECX(728.441,$ORDER(^ECX(728.441,"B",I,0)),0),U,2)
End DoDot:1
WRITE " CHAR4: ",CHAR4,!
+31 SET SDIV=$GET(^TMP("SDTMPUT4",$JOB,"DIV"))
+32 WRITE ?1,"DIVISION: ",$SELECT(SDIV="":"ALL",1:$PIECE($GET(^DG(40.8,SDIV,0)),U,1)),!
+33 WRITE ?1,"Clinic Name",?36,"IEN",?41,"CHAR4",?47,"SC#/CS#",?55,"Station",?63,"Provider (!Default Flag)",?89,"Default Provider",?116,"Updated",?127,"Flags",!
+34 WRITE ?1,"--------------------------------",?34,"------",?41,"-----",?47,"-------",?55,"-------",?63,"-------------------------",?89,"--------------------------",?116,"----------",?127,"-----",!
+35 QUIT
+36 ;
LINE ;Write a single clinic record
+1 NEW SDFLG,CLSTD,CLCRSD,CLSTI,CLCRSI
+2 SET FND=FND+1
SET CNT=CNT+1
SET SDFLG=" "
SET CLSTD=""
SET CLCRSD=""
SET CLSTI=""
SET CLCRSI=""
+3 IF FND#60=1
DO HEADER
+4 IF $PIECE(IN,U,1)>0
IF +$PIECE(IN,U,2)=0
SET $EXTRACT(SDFLG,1)="*"
SET INACT=INACT+1
+5 IF SDDIS
SET $EXTRACT(SDFLG,2)="+"
+6 IF CLSTC]""
SET CLSTD=$PIECE($GET(^DIC(40.7,CLSTC,0)),U,2)
SET CLSTI=$PIECE($GET(^DIC(40.7,CLSTC,0)),U,3)
+7 IF CLSTI
SET $EXTRACT(SDFLG,3)="S"
+8 IF CLSTD=""
SET CLSTD=" "
+9 IF CLCRSC]""
SET CLCRSD=$PIECE($GET(^DIC(40.7,CLCRSC,0)),U,2)
SET CLCRSI=$PIECE($GET(^DIC(40.7,CLCRSC,0)),U,3)
+10 IF CLCRSD=""
SET CLCRSD=" "
+11 IF CLCRSI
SET $EXTRACT(SDFLG,4)="C"
+12 NEW X,XL,CLIN
SET X=" "_CL
SET XL=$LENGTH(X)
SET CLIN=$EXTRACT(X,XL-5,XL)
+13 WRITE ?1,CLNAM,?34,CLIN,?41,CLCHAR4,?47,CLSTD,"/",CLCRSD,?55,$$GET1^DIQ(4,INST_",",99,"E"),?63,$EXTRACT($GET(PRV(1)),1,25),?89,$EXTRACT(DPR,1,25),?116,$PIECE($$AUDIT^SDTMPUT0(+CL),"@",1),?127,SDFLG,!
+14 IF PRV>1
FOR K=2:1:PRV
WRITE ?63,PRV(K),!
SET FND=FND+1
if FND#60=1
DO HEADER
+15 QUIT
+16 ;
END ;Clean up and Quit
+1 KILL ^TMP("SDTMPUT4",$JOB)
+2 KILL %ZIS,C,CHAR4,CL,CLCHAR4,CLCRSC,CLNAM,CLSTC,CNT,CRIT,CRITCNT,DIC,DIR,DIV,DP,DPR,FND,I,IN,INACT,INST,K,NODE0,PGNO,POP,PRNO,PRQTY,PRV,SC,SDDIS,SDIV,X,Y
+3 QUIT
+4 ;
ACT ;View active, inactive or both clinics
+1 KILL DIR,X,Y
+2 SET DIR(0)="SA^A:ACTIVE;I:INACTIVE;B:BOTH^"
SET DIR("B")="B"
+3 SET DIR("A")="List which clinics - (A)ctive, (I)nactive or (B)oth ? "
+4 DO ^DIR
+5 SET ^TMP("SDTMPUT4",$JOB,"ACT")=Y
+6 QUIT
+7 ;
DIV ;Ask DIVISION
+1 KILL DIC,X,Y
+2 ;,DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))"
SET DIC="^DG(40.8,"
SET DIC(0)="AEMQZ"
+3 SET DIC("A")="Select DIVISION: ALL// "
DO ^DIC
KILL DIC("S"),DIC("A")
if "^"[X
QUIT
IF +Y'>0
if +Y<0
GOTO DIV
+4 IF X="^"
QUIT
+5 SET ^TMP("SDTMPUT4",$JOB,"DIV")=$PIECE(Y,U,1)
+6 QUIT
+7 ;
CLINIC ;Ask CLINIC
+1 KILL C,CRIT,CRITCNT,D,DIR,FND,X,Y
+2 SET DIR(0)="FO"
SET DIR("A")="Select CLINIC NAME or ALL"
SET CRITCNT=""
SET CRITCNT=+$ORDER(^TMP("SDTMPUT4",$JOB,"CRI",CRITCNT),-1)
+3 SET DIR("?")=" "
+4 SET DIR("?",1)="Enter a partial clinic name to find all clinics beginning with"
+5 SET DIR("?",2)="that phrase. Use the left bracket ([) to find any clinics that"
+6 SET DIR("?",3)="contains that phrase anywhere in their name. Enter ALL to include"
+7 SET DIR("?",4)="all clinics. If you do not enter anything, ALL will be assumed."
+8 SET DIR("?",5)="You may enter more than one clinic name on separate lines."
+9 DO ^DIR
+10 IF X=""
IF $DATA(^TMP("SDTMPUT4",$JOB,"C"))
QUIT
+11 IF X=""
IF '$DATA(^TMP("SDTMPUT4",$JOB,"C"))
SET X="ALL"
WRITE "ALL"
+12 IF X="^"
QUIT
+13 ;Save criteria for report header
SET CRIT=X
+14 IF X="ALL"
Begin DoDot:1
+15 ;All overwrites previous selections
KILL ^TMP("SDTMPUT4",$JOB,"C")
+16 SET FND=""
FOR I=1:1
SET FND=$ORDER(^SC("B",FND))
if FND=""
QUIT
SET C=0
FOR
SET C=$ORDER(^SC("B",FND,C))
if 'C
QUIT
SET ^TMP("SDTMPUT4",$JOB,"C",FND,C)=""
+17 SET ^TMP("SDTMPUT4",$JOB,"CRI",1)="ALL"
End DoDot:1
QUIT
+18 SET D=X
+19 SET FND=$ORDER(^SC("B",D))
SET CNT=0
+20 IF X'["["
IF $EXTRACT(FND,1,$LENGTH(D))'=D
WRITE " NOT FOUND",!
GOTO CLINIC
+21 IF X["["
Begin DoDot:1
+22 SET FND=""
FOR I=1:1
SET FND=$ORDER(^SC("B",FND))
if FND=""
QUIT
IF FND[$PIECE(X,"[",2)
SET C=0
FOR
SET C=$ORDER(^SC("B",FND,C))
if 'C
QUIT
SET ^TMP("SDTMPUT4",$JOB,"C",FND,C)=""
SET CNT=CNT+1
+23 WRITE " ",CNT," CLINICS FOUND"
+24 SET CRITCNT=CRITCNT+1
SET ^TMP("SDTMPUT4",$JOB,"CRI",CRITCNT)=CRIT
End DoDot:1
+25 IF X]""
IF X'["["
Begin DoDot:1
+26 FOR I=1:1
SET FND=$ORDER(^SC("B",FND))
if $EXTRACT(FND,1,$LENGTH(D))'=D
QUIT
SET C=0
FOR
SET C=$ORDER(^SC("B",FND,C))
if 'C
QUIT
SET ^TMP("SDTMPUT4",$JOB,"C",FND,C)=""
SET CNT=CNT+1
+27 WRITE " ",CNT," CLINICS FOUND"
+28 SET CRITCNT=CRITCNT+1
SET ^TMP("SDTMPUT4",$JOB,"CRI",CRITCNT)=CRIT
End DoDot:1
+29 GOTO CLINIC
+30 QUIT
+31 ;
CHAR4 ;Ask CHAR4
+1 KILL DIC,X,Y
+2 SET DIC="^ECX(728.441,"
SET DIC(0)="AEMQZ"
+3 SET DIC("A")="Select CHAR4: "
DO ^DIC
KILL DIC("S"),DIC("A")
if "^"[X
QUIT
IF +Y'>0
GOTO CHAR4
+4 IF X="^"
QUIT
+5 WRITE " ",$PIECE(Y(0),U,2),!
+6 SET ^TMP("SDTMPUT4",$JOB,"CHAR4",$PIECE(Y,U,2))=""
+7 GOTO CHAR4
+8 QUIT
+9 ;
DEFPROV ;Ask DEFAULT PROVIDER
+1 KILL DIC,X,Y
+2 SET DIC="^VA(200,"
SET DIC(0)="AEMQZ"
+3 SET DIC("A")="Select DEFAULT PROVIDER: "
DO ^DIC
KILL DIC("S"),DIC("A")
if "^"[X
QUIT
IF +Y'>0
if +Y<0
GOTO DEFPROV
+4 IF X=""
QUIT
+5 IF X="^"
QUIT
+6 IF '$DATA(^SC("AVADPR",$PIECE(Y,U,1)))
WRITE " This person is not the default provider for any existing clinic",!
GOTO DEFPROV
+7 SET ^TMP("SDTMPUT4",$JOB,"DP",$PIECE(Y,U,1))=""
+8 GOTO DEFPROV
+9 QUIT
+10 ;
PROVIDER ;Ask PROVIDER From provider multiple
+1 KILL DIC,X,Y
+2 SET DIC="^VA(200,"
SET DIC(0)="AEMQZ"
+3 SET DIC("A")="Select PROVIDER: "
DO ^DIC
KILL DIC("S"),DIC("A")
if "^"[X
QUIT
if +Y<0
GOTO PROVIDER
+4 IF X=""
QUIT
+5 IF X="^"
QUIT
+6 SET ^TMP("SDTMPUT4",$JOB,"P",$PIECE(Y,U,1))=""
+7 GOTO PROVIDER
+8 QUIT
+9 ;
PROVMATCH(CLINIC) ;Does clinic match search provider(s)?
+1 NEW MATCH,PCNT,PRDUZ,PRNO,PRQTY
+2 SET PRQTY=+$PIECE($GET(^SC(CLINIC,"PR",0)),U,4)
IF PRQTY=0
QUIT 0
+3 SET PCNT=0
SET MATCH=0
+4 FOR PRNO=1:1:PRQTY
Begin DoDot:1
+5 SET PCNT=$ORDER(^SC(CLINIC,"PR",PCNT))
+6 SET PRDUZ=$PIECE(^SC(CLINIC,"PR",PCNT,0),U,1)
+7 IF $DATA(^TMP("SDTMPUT4",$JOB,"P",PRDUZ))
SET MATCH=1
QUIT
End DoDot:1
+8 QUIT MATCH
+9 ;
PRVARR ;Create provider array
+1 KILL PRV
+2 NEW PCNT,PRDEF,PRDUZ,PRNAM,PRQTY
+3 SET PRQTY=$PIECE($GET(^SC(CL,"PR",0)),U,4)
IF PRQTY=0
SET PRV=0
QUIT
+4 SET PCNT=0
+5 FOR PRNO=1:1:PRQTY
Begin DoDot:1
+6 SET PCNT=$ORDER(^SC(CL,"PR",PCNT))
+7 SET PRDUZ=$PIECE(^SC(CL,"PR",PCNT,0),U,1)
SET PRDEF=+$PIECE(^SC(CL,"PR",PCNT,0),U,2)
SET PRNAM=$PIECE($GET(^VA(200,PRDUZ,0)),U,1)
+8 SET PRV(PRNO)=PRNAM_$SELECT(PRDEF:"!",1:"")
End DoDot:1
+9 SET PRV=PRQTY
+10 QUIT
+11 ;
DPRVMTCH(DP) ;Does clinic match default provider(s)
+1 NEW MATCH,SDDP
+2 SET MATCH=0
+3 IF DP=""
QUIT MATCH
+4 SET SDDP=""
FOR
SET SDDP=$ORDER(^TMP("SDTMPUT4",$JOB,"DP",SDDP))
if SDDP=""
QUIT
IF SDDP=DP
SET MATCH=1
QUIT
+5 QUIT MATCH
+6 ;
SCTYPE ;Where do you want to search for STOP CODE?
+1 SET DIR(0)="FO"
SET DIR("A")="Select (S)TOP CODE, (C)REDIT STOP CODE or (B)OTH"
+2 SET DIR("?")=" "
+3 SET DIR("?",1)="Enter S to check for Stop Code in the primary position."
+4 SET DIR("?",2)="Enter C to check for a Stop Code in Credit Stop Code field"
+5 SET DIR("?",3)="Enter B to check for a Stop Code in both fields."
+6 DO ^DIR
+7 IF X=""
GOTO SCTYPE
+8 IF X="s"
SET X="S"
+9 IF X="c"
SET X="C"
+10 IF X="b"
SET X="B"
+11 IF X'="S"
IF X'="C"
IF X'="B"
WRITE " Invalid choice"
GOTO SCTYPE
+12 QUIT
+13 ;
SCCHK() ;Individual STOP CODE check
+1 NEW MATCH
+2 SET MATCH=0
+3 IF 'CLSTC
IF 'CLCRSC
QUIT MATCH
+4 IF CLSTC
IF $DATA(^TMP("SDTMPUT4",$JOB,"SC",CLSTC))
IF "BS"[$GET(^TMP("SDTMPUT4",$JOB,"SC",CLSTC))
SET MATCH=1
+5 IF CLCRSC
IF $DATA(^TMP("SDTMPUT4",$JOB,"SC",CLCRSC))
IF "BC"[$GET(^TMP("SDTMPUT4",$JOB,"SC",CLCRSC))
SET MATCH=1
+6 QUIT MATCH
+7 ;
SCPCHK() ;Pair STOP CODE check
+1 NEW SCP,CLSTP,CLCRSP,MATCH
+2 SET MATCH=0
+3 IF 'CLSTC
QUIT MATCH
+4 IF 'CLCRSC
QUIT MATCH
+5 SET SCP=""
SET SCP=$ORDER(^TMP("SDTMPUT4",$JOB,"SCP",SCP))
+6 SET CLSTP=$EXTRACT(SCP,1,3)
SET CLCRSP=$EXTRACT(SCP,4,6)
+7 IF CLSTP=CLSTC
IF CLCRSP=CLCRSC
SET MATCH=1
+8 QUIT MATCH
+9 ;
STOPCODEX ;Ask STOP CODE
+1 NEW ERROR,SCP
+2 SET DIR(0)="FO"
+3 SET DIR("A")=$SELECT($DATA(^TMP("SDTMPUT4",$JOB,"SC")):"Select STOP CODE",1:"Select STOP CODE or PAIR")
+4 SET DIR("?")=" "
+5 SET DIR("?",1)="Enter a stop code or stop code pair. Stop code pairs must be "
+6 SET DIR("?",2)="entered one per report with no other stop codes or pairs entered."
+7 SET DIR("?",3)="Stop code pairs are entered as a 6 digit number with no slash or other"
+8 SET DIR("?",4)="separator. Individual stop codes can be entered in multiples one at a"
+9 SET DIR("?",5)="time on separate lines. You can search for individual stop codes as the"
+10 SET DIR("?",6)="primary stop code, credit stop code or both."
+11 DO ^DIR
+12 IF X=""
IF $DATA(^TMP("SDTMPUT4",$JOB,"SC"))
QUIT
+13 IF X=""
QUIT
+14 IF X="^"
QUIT
+15 IF X'?2.6N
WRITE " INVALID STOP CODE"
GOTO STOPCODEX
+16 IF X?2.3N
Begin DoDot:1
+17 SET ERROR=0
SET ERROR=$$SCLU(X,0)
IF 'ERROR
SET ^TMP("SDTMPUT4",$JOB,"SC",SC)=X
End DoDot:1
+18 IF X?6N
Begin DoDot:1
+19 IF $DATA(^TMP("SDTMPUT4",$JOB,"SC"))
WRITE ?34,"STOP CODE PAIRS MUST BE ENTERED ALONE",!
QUIT
+20 SET ERROR=0
+21 SET ERROR=ERROR+$$SCLU($EXTRACT(X,1,3),1)
+22 IF 'ERROR
SET $EXTRACT(SCP,1,3)=SC
+23 SET ERROR=ERROR+$$SCLU($EXTRACT(X,4,6),1)
+24 IF 'ERROR
SET $EXTRACT(SCP,4,6)=SC
+25 IF ERROR
WRITE ?34,"INVALID PAIR",!
QUIT
+26 SET ^TMP("SDTMPUT4",$JOB,"SCP",SCP)=""
End DoDot:1
+27 IF $DATA(^TMP("SDTMPUT4",$JOB,"SCP"))
QUIT
+28 GOTO STOPCODEX
+29 QUIT
SCLU(CODE,PAIR) ;Return SCERR=1 error, SCERR=0 no error
+1 NEW SC0
+2 SET CODE=+CODE
+3 IF '$DATA(^DIC(40.7,"C",CODE))
WRITE ?34,"NOT FOUND",!
QUIT 1
+4 IF $DATA(^DIC(40.7,"C",CODE))
SET SC=""
SET SC=$ORDER(^DIC(40.7,"C",CODE,SC))
+5 SET SC0=^DIC(40.7,SC,0)
+6 WRITE ?34,$PIECE(SC0,U,2)," - ",$PIECE(SC0,U,1)
+7 IF $PIECE(SC0,U,3)
WRITE " (INACTIVE)"
+8 IF 'PAIR
DO SCTYPE
+9 WRITE !
+10 QUIT 0
