- SDUTL2 ;ALB/CAW - Misc. utilities ; 6/28/07 11:48am
- ;;5.3;Scheduling;**20,71,132,149,175,193,220,258,380,516**;Aug 13, 1993;Build 3
- ;
- ;
- 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*
- 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)
- ;
- S SDCS=$P($G(^DIC(40.7,+SDSTOP,0)),"^",2),SDMH=$S(SDNOGAF[SDCS:0,$E(SDCS)=5:1,1:0)
- 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
- ;
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDUTL2 8577 printed Jan 18, 2025@04:03:03 Page 2
- SDUTL2 ;ALB/CAW - Misc. utilities ; 6/28/07 11:48am
- +1 ;;5.3;Scheduling;**20,71,132,149,175,193,220,258,380,516**;Aug 13, 1993;Build 3
- +2 ;
- +3 ;
- 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 ;DBIA #2349
- IF $$ACTIVPRV^PXAPI(+Y,SDDT)
- SET SDY=1
- +33 ; end patch *516*
- +34 QUIT SDY
- +35 ;
- 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 SET SDCS=$PIECE($GET(^DIC(40.7,+SDSTOP,0)),"^",2)
- SET SDMH=$SELECT(SDNOGAF[SDCS:0,$EXTRACT(SDCS)=5:1,1:0)
- +19 QUIT SDMH
- +20 ;
- 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 NEW SCN,RTY,CTY,RDT,STR,STYP
- +8 SET DIS=$GET(DIS,0)
- SET STYP="("_$SELECT(TYP="P":"Prim",1:"Second")_"ary)"
- +9 IF +SCIEN<1
- SET STR="Invalid Clinic Stop Code "_STYP_"."
- DO MSG
- QUIT "0^"_STR
- +10 SET CTY=$SELECT(TYP="P":"^P^E^",1:"^S^E^")
- +11 SET SCN=$GET(^DIC(40.7,SCIEN,0))
- SET RTY=$PIECE(SCN,U,6)
- SET RDT=$PIECE(SCN,U,7)
- +12 IF RTY=""
- Begin DoDot:1
- +13 SET STR="Clinic's Stop Code "_$PIECE(SCN,U,2)_" has no restriction type "_STYP_"."
- DO MSG
- End DoDot:1
- QUIT "0^"_STR
- +14 IF CTY'[("^"_RTY_"^")
- Begin DoDot:1
- +15 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
- +16 IF RDT>DT
- Begin DoDot:1
- +17 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
- +18 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