SDUTL2 ;ALB/CAW - Misc. utilities ; 6/28/07 11:48am
;;5.3;Scheduling;**20,71,132,149,175,193,220,258,380,516,1015**;Aug 13, 1993;Build 21
;IHS/ANMC/LJF 8/15/2001 bypass checking for HCFA occupation class
;
;
FYNUNK(SD) ; return YES, NO, UNKNOWN
; input: SD=internal piece
; output: [returned] Y=YES, N=NO, U=UNKNOWN
Q $S(SD="Y":"YES",SD="N":"NO",SD="U":"UNKNOWN",1:"")
;
FMT(DFN) ; return current status of means test in external form
; input: DFN=ifn of patient
; ouput: [returned] MT^SMT^LST
; MT=external format of current status
; SMT=shortened format of current staus
; LST=date of last test
;
N X,Y
S X=$$LST^DGMTU(DFN)
S Y=$P(X,U,4),Y=$S(Y["B":"CAT "_Y,Y["A":"COPAY EX",Y["C":"COPAY REQ",Y["G":"GMT COPAY REQ",Y["R":"REQ",Y["P":"PEND ADJ",Y["N":"NOT REQ",1:"")
Q $P(X,U,3)_U_Y_U_$P(X,U,2)
;
FCO(DFN) ; return current status of copay test in external form
; input: DFN=ifn of patient
; ouput: [returned] COT^SCOT^LST
; COT=external format of current status
; SCOT=shortened format of current staus
; LST=date of last test
;
N X,Y
S X=$$LST^DGMTU(DFN,"",2)
S Y=$P(X,U,4),Y=$S(Y["E":"EXEMPT",Y["M":"NON-EXEMPT",Y["I":"INCOMPLETE",Y["L":"NO LONGER APPL.",1:"")
Q $P(X,U,3)_U_Y_U_$P(X,U,2)
;
XMY(GROUP,SDUZ,SDPOST) ; -- set up XMY for mail group members
; input: GROUP := mail group efn [required]
; SDUZ := send to current user [ 0|no ; 1|yes] [optional]
; SDPOST := send to postmaster if XMY is undefined
; [ 0|no ; 1|yes] [optional]
; output: XMY := array of users
; XMDUZ := message sender set postmaster
;
N I K XMY
I '$D(SDUZ) N SDUZ S SDUZ=1
I '$D(SDPOST) N SDPOST S SDPOST=1
S XMY("G."_$P($G(^XMB(3.8,GROUP,0)),U))=""
I SDUZ,DUZ S XMY(DUZ)=""
; makes sure it gets sent to someone
I '$D(XMY),SDPOST S XMY(.5)=""
; make postmaster the sender so it will show up as new to DUZ
S XMDUZ=.5
Q
;
SCREEN(Y,SDDT) ; -- screen called when entering a provider in the
; DEFAULT PROVIDER field (#16) or PROVIDER field (#.01) of the PROVIDER
; multiple (#2600) in the HOSPITAL LOCATION file (#44).
;
; Selects active providers with an active entry in the NEW PERSON
; file (#200) for PERSON CLASS.
;
; INPUT: Y = ien of file 200
; SDDT = today's date
; OUTPUT: 1 to select; 0 to not select
;
; begin patch *516*
; DBIA #2349 - ACTIVE PROVIDER will be used for validation.
; The INACTIVE DATE (#53.4) field will no longer be used.
; New input selection logic...
; The TERMINATION DATE (#9.2) and the PERSON CLASS (#8932.1) fields
; will be used to determine if selection is active in the
; NEW PERSON (#200) file for a given date.
;
;S:'+$G(SDDT) SDDT=DT I '+$G(Y) Q 0
;N SDINACT,SDT,SDY S SDY=0
; check if provider active
;S SDINACT=$G(^VA(200,+Y,"PS"))
;Q:'$S(SDINACT']"":1,'+$P(SDINACT,"^",4):1,DT<+$P(SDINACT,"^",4):1,1:0) SDY
;S SDT=+$P($G(^VA(200,+Y,0)),U,11)
;Q:$S('SDT:0,(SDT<DT):1,1:0) 0
;I $$GET^XUA4A72(Y,SDDT)>0 S SDY=1
;
I '+$G(Y) Q 0
N SDY
S:'+$G(SDDT) SDDT=DT
S SDY=0,SDDT=$P(SDDT,".")
;I $$ACTIVPRV^PXAPI(+Y,SDDT) S SDY=1 ;DBIA #2349
; end patch *516*
S SDY=1 ;ihs/cmi/maw 06/21/2012 PATCH 1015 not using PCE API's
Q SDY
;
HELP(SDDT) ; -- executable help called when entering a provider in the
; DEFAULT PROVIDER field (#16) or PROVIDER field (#.01) of the PROVIDER
; multiple (#2600) in the HOSPITAL LOCATION file (#44), the PROVIDER
; (#.01) field of the V PROVIDER file (#9000010.06), or in the
; PROVIDER prompt of the Check-out screen. display active providers
; with an active entry in the NEW PERSON file (#200) for PERSON CLASS.
;
; INPUT: SDDT = today's date
; OUTPUT: display of active providers with an active entry in the NEW
; PERSON file (#200) for PERSON CLASS
;
S:'+$G(SDDT) SDDT=DT
N D,DO,DIC,X
S X="??",DIC="^VA(200,",DIC(0)="EQ",D="B"
S DIC("S")="I $$SCREEN^SDUTL2(Y,SDDT)"
D IX^DIC
Q
;
SCAN(SDINDEX,SDBEG,SDEND,SDCB,SDFN,SDIR) ; -- api to invoke scan
N SDQID
D OPEN^SDQ(.SDQID)
D INDEX^SDQ(.SDQID,SDINDEX,"SET")
IF SDINDEX="PATIENT/DATE"!(SDINDEX="PATIENT") D PAT^SDQ(.SDQID,SDFN,"SET")
IF SDINDEX="PATIENT/DATE"!(SDINDEX="DATE/TIME") D DATE^SDQ(.SDQID,SDBEG,SDEND,"SET")
D SCANCB^SDQ(.SDQID,SDCB,"SET")
D ACTIVE^SDQ(.SDQID,"TRUE","SET")
D SCAN^SDQ(.SDQID,SDIR)
D CLOSE^SDQ(.SDQID)
SCANQ Q
;
MHCLIN(SDCL,SDSC) ;;Determines if Mental health Clinic requiring GAF
;;This will be a supported call
;;Determines whether the clinic passed is a Mental Health clinic that requires Gaf
;;Input - SDCL = Clinic IEN
;; SDSC = DSS Stop Code [Optional]
;; For Visit File entries where the Clinic IEN is not available
;; but the DSS identifier is.
;;
;;Output - 1 = Mental health clinic requiring a Gaf
;; 0 = Not a clinic requiring a Gaf
N SDNOGAF,SDSTOP,SDCS,SDMH
S SDNOGAF="526,527,528,530,533,536,537,542,545,546,565,566,573,574,579"
;; Get either the Clinic IEN or the Clinic Stop code
I $G(SDCL) D
. S SDSTOP=$P($G(^SC(SDCL,0)),"^",7)
E D
. S SDSTOP=$G(SDSC)
;
;IHS/ITSC/WAR 4/15/04 Mod to handle 2 digit clinic codes (STOP CODES)
; starting with the number 5
;S SDCS=$P($G(^DIC(40.7,+SDSTOP,0)),"^",2),SDMH=$S(SDNOGAF[SDCS:0,$E(SDCS)=5:1,1:0)
S SDCS=$P($G(^DIC(40.7,+SDSTOP,0)),"^",2)
I $L(SDCS)=2 Q 0
S SDMH=$S(SDNOGAF[SDCS:0,$E(SDCS)=5:1,1:0)
;IHS/ITSC/WAR 4/15/04 end
Q SDMH
;
NEWGAF(DFN) ;;Determine if new GAF Score needed
;;This will be a supported call
;;Determines if a new Gaf is required for a patient and retrieves previous Gaf data
;; If patient is deceased, returns a 0, no new GAF required
;;
;;Input - Patient IEN
;;Output:
;; piece 1 = -1 if New Gaf needed and no previous data
;; = 1 if New Gaf needed and previous data exists
;; = 0 if no New Gaf needed and previous exists
;; piece 2 = previous Gaf score
;; piece 3 = previous Gaf date
;; piece 4 = previous Gaf Providers IEN
;;
N SDGAF,SDGAFDT,VADM
;
S SDGAF=$$RET^YSGAF(DFN)
;; Check for deceased patient.
D DEM^VADPT
Q:+$G(VADM(6)) "0^"_SDGAF_"^1"
D KVAR^VADPT
;
Q:SDGAF=-1 -1
S X1=$P(SDGAF,"^",2),X2=90 D C^%DTC
Q $S(DT>X:1,1:0)_"^"_SDGAF
;
GAFCM() ;;
N DIR,DIRUT
S DIR("A",1)="But a new GAF Score is needed for this patient!"
S DIR("A")="Are you sure you want to bypass the check out screen? "
S DIR("B")="No",DIR(0)="YA" W ! D ^DIR
Q +$G(Y)
COLLAT(SDEC) ;Determines if patient has a collateral eligibility status
;
; INPUT: SDEC = patient eligibility status
;
; OUTPUT: 1 = collateral patient
; 0 = non-collateral patient
;
Q:$G(SDEC)="" 0
I $$GET1^DIQ(8,SDEC,8,"I")=13 Q 1
Q 0
;
ELSTAT(DA) ;Retrieve patient eligibility status
;
; INPUT: DA = patient IEN
;
; OUTPUT:
; Function Value - returns the internal entry number for patient's
; eligibility status.
;
Q:$G(DA)="" ""
Q $$GET1^DIQ(2,DA,.361,"I")
SCREST(SCIEN,TYP,DIS) ;check stop code restriction in file 40.7 for a clinic.
; INPUT: SCIEN = IEN of Stop Code
; TYP = Stop Code Type, Primary (P) or Secondary (S)
; DIS = Message Display, 1 - Display or 0 No Display
;
; OUTPUT: 1 if no error, or 0^error message
;
Q 1 ;ihs/cmi/maw 03/30/2012 not used in IHS
N SCN,RTY,CTY,RDT,STR,STYP
S DIS=$G(DIS,0),STYP="("_$S(TYP="P":"Prim",1:"Second")_"ary)"
I +SCIEN<1 S STR="Invalid Clinic Stop Code "_STYP_"." D MSG Q "0^"_STR
S CTY=$S(TYP="P":"^P^E^",1:"^S^E^")
S SCN=$G(^DIC(40.7,SCIEN,0)),RTY=$P(SCN,U,6),RDT=$P(SCN,U,7)
I RTY="" D Q "0^"_STR
.S STR="Clinic's Stop Code "_$P(SCN,U,2)_" has no restriction type "_STYP_"." D MSG
I CTY'[("^"_RTY_"^") D D MSG Q "0^"_STR
.S STR="Clinic's Stop Code "_$P(SCN,U,2)_" cannot be "_$S(TYP="P":"Prim",1:"Second")_"ary."
I RDT>DT D D MSG Q "0^"_STR
.S STR="Clinic's Stop Code "_$P(SCN,U,2)_" cannot be used. Restriction date is "_$$FMTE^XLFDT(RDT,"1F")_" "_STYP_"."
Q 1
MSG ;display error message to screen
I DIS,$E($G(IOST))="C" W !?5,STR
Q
CLNCK(CLN,DSP) ;Check clinic for valid stop code restriction.
; INPUT: CLN = IEN of Clinic
; DSP = Error Message Display, 1 - Display or 0 No Display
;
; OUTPUT: 1 if no error or 0^error message
N PSC,SSC,ND0,VAL
S DSP=$G(DSP,0)
I CLN="" D Q "0^"_"Invalid Clinic."
.I DSP,$E($G(IOST))="C" W !?5,"Invalid Clinic."
I $G(^SC(CLN,0))="" D Q "0^"_"Clinic not define or has no zero node."
.I DSP,$E($G(IOST))="C" W !?5,"Clinic not define or has no zero node."
S ND0=^SC(CLN,0),PSC=$P(ND0,U,7),SSC=$P(ND0,U,18),DSP=$G(DSP,0)
I $P(ND0,U,3)'="C" Q 1 ;not a Clinic
S VAL=$$SCREST(PSC,"P",DSP)
Q:'VAL VAL Q:SSC="" 1
S VAL=$$SCREST(SSC,"S",DSP)
Q VAL
SDUTL2 ;ALB/CAW - Misc. utilities ; 6/28/07 11:48am
+1 ;;5.3;Scheduling;**20,71,132,149,175,193,220,258,380,516,1015**;Aug 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 8/15/2001 bypass checking for HCFA occupation class
+3 ;
+4 ;
FYNUNK(SD) ; return YES, NO, UNKNOWN
+1 ; input: SD=internal piece
+2 ; output: [returned] Y=YES, N=NO, U=UNKNOWN
+3 QUIT $SELECT(SD="Y":"YES",SD="N":"NO",SD="U":"UNKNOWN",1:"")
+4 ;
FMT(DFN) ; return current status of means test in external form
+1 ; input: DFN=ifn of patient
+2 ; ouput: [returned] MT^SMT^LST
+3 ; MT=external format of current status
+4 ; SMT=shortened format of current staus
+5 ; LST=date of last test
+6 ;
+7 NEW X,Y
+8 SET X=$$LST^DGMTU(DFN)
+9 SET Y=$PIECE(X,U,4)
SET Y=$SELECT(Y["B":"CAT "_Y,Y["A":"COPAY EX",Y["C":"COPAY REQ",Y["G":"GMT COPAY REQ",Y["R":"REQ",Y["P":"PEND ADJ",Y["N":"NOT REQ",1:"")
+10 QUIT $PIECE(X,U,3)_U_Y_U_$PIECE(X,U,2)
+11 ;
FCO(DFN) ; return current status of copay test in external form
+1 ; input: DFN=ifn of patient
+2 ; ouput: [returned] COT^SCOT^LST
+3 ; COT=external format of current status
+4 ; SCOT=shortened format of current staus
+5 ; LST=date of last test
+6 ;
+7 NEW X,Y
+8 SET X=$$LST^DGMTU(DFN,"",2)
+9 SET Y=$PIECE(X,U,4)
SET Y=$SELECT(Y["E":"EXEMPT",Y["M":"NON-EXEMPT",Y["I":"INCOMPLETE",Y["L":"NO LONGER APPL.",1:"")
+10 QUIT $PIECE(X,U,3)_U_Y_U_$PIECE(X,U,2)
+11 ;
XMY(GROUP,SDUZ,SDPOST) ; -- set up XMY for mail group members
+1 ; input: GROUP := mail group efn [required]
+2 ; SDUZ := send to current user [ 0|no ; 1|yes] [optional]
+3 ; SDPOST := send to postmaster if XMY is undefined
+4 ; [ 0|no ; 1|yes] [optional]
+5 ; output: XMY := array of users
+6 ; XMDUZ := message sender set postmaster
+7 ;
+8 NEW I
KILL XMY
+9 IF '$DATA(SDUZ)
NEW SDUZ
SET SDUZ=1
+10 IF '$DATA(SDPOST)
NEW SDPOST
SET SDPOST=1
+11 SET XMY("G."_$PIECE($GET(^XMB(3.8,GROUP,0)),U))=""
+12 IF SDUZ
IF DUZ
SET XMY(DUZ)=""
+13 ; makes sure it gets sent to someone
+14 IF '$DATA(XMY)
IF SDPOST
SET XMY(.5)=""
+15 ; make postmaster the sender so it will show up as new to DUZ
+16 SET XMDUZ=.5
+17 QUIT
+18 ;
SCREEN(Y,SDDT) ; -- screen called when entering a provider in the
+1 ; DEFAULT PROVIDER field (#16) or PROVIDER field (#.01) of the PROVIDER
+2 ; multiple (#2600) in the HOSPITAL LOCATION file (#44).
+3 ;
+4 ; Selects active providers with an active entry in the NEW PERSON
+5 ; file (#200) for PERSON CLASS.
+6 ;
+7 ; INPUT: Y = ien of file 200
+8 ; SDDT = today's date
+9 ; OUTPUT: 1 to select; 0 to not select
+10 ;
+11 ; begin patch *516*
+12 ; DBIA #2349 - ACTIVE PROVIDER will be used for validation.
+13 ; The INACTIVE DATE (#53.4) field will no longer be used.
+14 ; New input selection logic...
+15 ; The TERMINATION DATE (#9.2) and the PERSON CLASS (#8932.1) fields
+16 ; will be used to determine if selection is active in the
+17 ; NEW PERSON (#200) file for a given date.
+18 ;
+19 ;S:'+$G(SDDT) SDDT=DT I '+$G(Y) Q 0
+20 ;N SDINACT,SDT,SDY S SDY=0
+21 ; check if provider active
+22 ;S SDINACT=$G(^VA(200,+Y,"PS"))
+23 ;Q:'$S(SDINACT']"":1,'+$P(SDINACT,"^",4):1,DT<+$P(SDINACT,"^",4):1,1:0) SDY
+24 ;S SDT=+$P($G(^VA(200,+Y,0)),U,11)
+25 ;Q:$S('SDT:0,(SDT<DT):1,1:0) 0
+26 ;I $$GET^XUA4A72(Y,SDDT)>0 S SDY=1
+27 ;
+28 IF '+$GET(Y)
QUIT 0
+29 NEW SDY
+30 IF '+$GET(SDDT)
SET SDDT=DT
+31 SET SDY=0
SET SDDT=$PIECE(SDDT,".")
+32 ;I $$ACTIVPRV^PXAPI(+Y,SDDT) S SDY=1 ;DBIA #2349
+33 ; end patch *516*
+34 ;ihs/cmi/maw 06/21/2012 PATCH 1015 not using PCE API's
SET SDY=1
+35 QUIT SDY
+36 ;
HELP(SDDT) ; -- executable help called when entering a provider in the
+1 ; DEFAULT PROVIDER field (#16) or PROVIDER field (#.01) of the PROVIDER
+2 ; multiple (#2600) in the HOSPITAL LOCATION file (#44), the PROVIDER
+3 ; (#.01) field of the V PROVIDER file (#9000010.06), or in the
+4 ; PROVIDER prompt of the Check-out screen. display active providers
+5 ; with an active entry in the NEW PERSON file (#200) for PERSON CLASS.
+6 ;
+7 ; INPUT: SDDT = today's date
+8 ; OUTPUT: display of active providers with an active entry in the NEW
+9 ; PERSON file (#200) for PERSON CLASS
+10 ;
+11 IF '+$GET(SDDT)
SET SDDT=DT
+12 NEW D,DO,DIC,X
+13 SET X="??"
SET DIC="^VA(200,"
SET DIC(0)="EQ"
SET D="B"
+14 SET DIC("S")="I $$SCREEN^SDUTL2(Y,SDDT)"
+15 DO IX^DIC
+16 QUIT
+17 ;
SCAN(SDINDEX,SDBEG,SDEND,SDCB,SDFN,SDIR) ; -- api to invoke scan
+1 NEW SDQID
+2 DO OPEN^SDQ(.SDQID)
+3 DO INDEX^SDQ(.SDQID,SDINDEX,"SET")
+4 IF SDINDEX="PATIENT/DATE"!(SDINDEX="PATIENT")
DO PAT^SDQ(.SDQID,SDFN,"SET")
+5 IF SDINDEX="PATIENT/DATE"!(SDINDEX="DATE/TIME")
DO DATE^SDQ(.SDQID,SDBEG,SDEND,"SET")
+6 DO SCANCB^SDQ(.SDQID,SDCB,"SET")
+7 DO ACTIVE^SDQ(.SDQID,"TRUE","SET")
+8 DO SCAN^SDQ(.SDQID,SDIR)
+9 DO CLOSE^SDQ(.SDQID)
SCANQ QUIT
+1 ;
MHCLIN(SDCL,SDSC) ;;Determines if Mental health Clinic requiring GAF
+1 ;;This will be a supported call
+2 ;;Determines whether the clinic passed is a Mental Health clinic that requires Gaf
+3 ;;Input - SDCL = Clinic IEN
+4 ;; SDSC = DSS Stop Code [Optional]
+5 ;; For Visit File entries where the Clinic IEN is not available
+6 ;; but the DSS identifier is.
+7 ;;
+8 ;;Output - 1 = Mental health clinic requiring a Gaf
+9 ;; 0 = Not a clinic requiring a Gaf
+10 NEW SDNOGAF,SDSTOP,SDCS,SDMH
+11 SET SDNOGAF="526,527,528,530,533,536,537,542,545,546,565,566,573,574,579"
+12 ;; Get either the Clinic IEN or the Clinic Stop code
+13 IF $GET(SDCL)
Begin DoDot:1
+14 SET SDSTOP=$PIECE($GET(^SC(SDCL,0)),"^",7)
End DoDot:1
+15 IF '$TEST
Begin DoDot:1
+16 SET SDSTOP=$GET(SDSC)
End DoDot:1
+17 ;
+18 ;IHS/ITSC/WAR 4/15/04 Mod to handle 2 digit clinic codes (STOP CODES)
+19 ; starting with the number 5
+20 ;S SDCS=$P($G(^DIC(40.7,+SDSTOP,0)),"^",2),SDMH=$S(SDNOGAF[SDCS:0,$E(SDCS)=5:1,1:0)
+21 SET SDCS=$PIECE($GET(^DIC(40.7,+SDSTOP,0)),"^",2)
+22 IF $LENGTH(SDCS)=2
QUIT 0
+23 SET SDMH=$SELECT(SDNOGAF[SDCS:0,$EXTRACT(SDCS)=5:1,1:0)
+24 ;IHS/ITSC/WAR 4/15/04 end
+25 QUIT SDMH
+26 ;
NEWGAF(DFN) ;;Determine if new GAF Score needed
+1 ;;This will be a supported call
+2 ;;Determines if a new Gaf is required for a patient and retrieves previous Gaf data
+3 ;; If patient is deceased, returns a 0, no new GAF required
+4 ;;
+5 ;;Input - Patient IEN
+6 ;;Output:
+7 ;; piece 1 = -1 if New Gaf needed and no previous data
+8 ;; = 1 if New Gaf needed and previous data exists
+9 ;; = 0 if no New Gaf needed and previous exists
+10 ;; piece 2 = previous Gaf score
+11 ;; piece 3 = previous Gaf date
+12 ;; piece 4 = previous Gaf Providers IEN
+13 ;;
+14 NEW SDGAF,SDGAFDT,VADM
+15 ;
+16 SET SDGAF=$$RET^YSGAF(DFN)
+17 ;; Check for deceased patient.
+18 DO DEM^VADPT
+19 IF +$GET(VADM(6))
QUIT "0^"_SDGAF_"^1"
+20 DO KVAR^VADPT
+21 ;
+22 IF SDGAF=-1
QUIT -1
+23 SET X1=$PIECE(SDGAF,"^",2)
SET X2=90
DO C^%DTC
+24 QUIT $SELECT(DT>X:1,1:0)_"^"_SDGAF
+25 ;
GAFCM() ;;
+1 NEW DIR,DIRUT
+2 SET DIR("A",1)="But a new GAF Score is needed for this patient!"
+3 SET DIR("A")="Are you sure you want to bypass the check out screen? "
+4 SET DIR("B")="No"
SET DIR(0)="YA"
WRITE !
DO ^DIR
+5 QUIT +$GET(Y)
COLLAT(SDEC) ;Determines if patient has a collateral eligibility status
+1 ;
+2 ; INPUT: SDEC = patient eligibility status
+3 ;
+4 ; OUTPUT: 1 = collateral patient
+5 ; 0 = non-collateral patient
+6 ;
+7 IF $GET(SDEC)=""
QUIT 0
+8 IF $$GET1^DIQ(8,SDEC,8,"I")=13
QUIT 1
+9 QUIT 0
+10 ;
ELSTAT(DA) ;Retrieve patient eligibility status
+1 ;
+2 ; INPUT: DA = patient IEN
+3 ;
+4 ; OUTPUT:
+5 ; Function Value - returns the internal entry number for patient's
+6 ; eligibility status.
+7 ;
+8 IF $GET(DA)=""
QUIT ""
+9 QUIT $$GET1^DIQ(2,DA,.361,"I")
SCREST(SCIEN,TYP,DIS) ;check stop code restriction in file 40.7 for a clinic.
+1 ; INPUT: SCIEN = IEN of Stop Code
+2 ; TYP = Stop Code Type, Primary (P) or Secondary (S)
+3 ; DIS = Message Display, 1 - Display or 0 No Display
+4 ;
+5 ; OUTPUT: 1 if no error, or 0^error message
+6 ;
+7 ;ihs/cmi/maw 03/30/2012 not used in IHS
QUIT 1
+8 NEW SCN,RTY,CTY,RDT,STR,STYP
+9 SET DIS=$GET(DIS,0)
SET STYP="("_$SELECT(TYP="P":"Prim",1:"Second")_"ary)"
+10 IF +SCIEN<1
SET STR="Invalid Clinic Stop Code "_STYP_"."
DO MSG
QUIT "0^"_STR
+11 SET CTY=$SELECT(TYP="P":"^P^E^",1:"^S^E^")
+12 SET SCN=$GET(^DIC(40.7,SCIEN,0))
SET RTY=$PIECE(SCN,U,6)
SET RDT=$PIECE(SCN,U,7)
+13 IF RTY=""
Begin DoDot:1
+14 SET STR="Clinic's Stop Code "_$PIECE(SCN,U,2)_" has no restriction type "_STYP_"."
DO MSG
End DoDot:1
QUIT "0^"_STR
+15 IF CTY'[("^"_RTY_"^")
Begin DoDot:1
+16 SET STR="Clinic's Stop Code "_$PIECE(SCN,U,2)_" cannot be "_$SELECT(TYP="P":"Prim",1:"Second")_"ary."
End DoDot:1
DO MSG
QUIT "0^"_STR
+17 IF RDT>DT
Begin DoDot:1
+18 SET STR="Clinic's Stop Code "_$PIECE(SCN,U,2)_" cannot be used. Restriction date is "_$$FMTE^XLFDT(RDT,"1F")_" "_STYP_"."
End DoDot:1
DO MSG
QUIT "0^"_STR
+19 QUIT 1
MSG ;display error message to screen
+1 IF DIS
IF $EXTRACT($GET(IOST))="C"
WRITE !?5,STR
+2 QUIT
CLNCK(CLN,DSP) ;Check clinic for valid stop code restriction.
+1 ; INPUT: CLN = IEN of Clinic
+2 ; DSP = Error Message Display, 1 - Display or 0 No Display
+3 ;
+4 ; OUTPUT: 1 if no error or 0^error message
+5 NEW PSC,SSC,ND0,VAL
+6 SET DSP=$GET(DSP,0)
+7 IF CLN=""
Begin DoDot:1
+8 IF DSP
IF $EXTRACT($GET(IOST))="C"
WRITE !?5,"Invalid Clinic."
End DoDot:1
QUIT "0^"_"Invalid Clinic."
+9 IF $GET(^SC(CLN,0))=""
Begin DoDot:1
+10 IF DSP
IF $EXTRACT($GET(IOST))="C"
WRITE !?5,"Clinic not define or has no zero node."
End DoDot:1
QUIT "0^"_"Clinic not define or has no zero node."
+11 SET ND0=^SC(CLN,0)
SET PSC=$PIECE(ND0,U,7)
SET SSC=$PIECE(ND0,U,18)
SET DSP=$GET(DSP,0)
+12 ;not a Clinic
IF $PIECE(ND0,U,3)'="C"
QUIT 1
+13 SET VAL=$$SCREST(PSC,"P",DSP)
+14 IF 'VAL
QUIT VAL
IF SSC=""
QUIT 1
+15 SET VAL=$$SCREST(SSC,"S",DSP)
+16 QUIT VAL
