- ORCDRA1 ;SLC/MKB-Utility functions for RA dialogs ; 08 May 2002 2:12 PM
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,75,141**;Dec 17, 1997
- DIV() ; -- Returns division of ordering location
- N Y I $G(ORL),'$G(OREVENT) S Y=+$P($G(^SC(+ORL,0)),U,15),Y=+$$SITE^VASITE(DT,Y)
- I $G(OREVENT) S Y=+$$DIV^OREVNTX(OREVENT)
- S:$G(Y)'>0 Y=+$G(DUZ(2))
- DIVQ Q Y
- ;
- CKPTYPE ; -- Check procedure for Series type
- N PTYPE S PTYPE=$P($G(^ORD(101.43,+$$VAL^ORCD("PROCEDURE"),"RA")),U,2)
- Q:PTYPE'="S" Q:'$L($P($G(^RAMIS(71.2,+Y,0)),U,2))
- W $C(7),!,"This procedure modifier may not be selected with a procedure series!",!
- K DONE,ORDIALOG(PROMPT,ORI)
- Q
- ;
- VALIDWP(ROOT) ; -- Validate wp field (borrowed from VALWP^RAUTL5)
- ; Pass back '1' is data is valid, '0' if not valid.
- Q:'$L($G(ROOT)) 0 Q:'$O(@(ROOT_"0)")) 0
- N CHAR,CNT,WL,WPFLG,X,Y,Z
- S (WPFLG,X)=0
- F S X=$O(@(ROOT_X_")")) Q:X'>0 D Q:WPFLG
- . S (CNT,WL)=0
- . S Y=$G(@(ROOT_X_",0)")) Q:Y']""
- . S WL=$L(Y)
- . F Z=1:1:WL D Q:WPFLG
- .. S CHAR=$E(Y,Z) S:CHAR?1AN CNT=CNT+1
- .. S:CHAR'?1AN&(CNT>0) CNT=0 S:CNT=2 WPFLG=1
- Q WPFLG
- ;
- CHNGCAT ; -- Kill dependent values if Category changes
- N P,PTR
- F P="LOCATION","CONTRACT/SHARING SOURCE","RESEARCH SOURCE" D
- . S PTR=+$O(^ORD(101.41,"AB",$E("OR GTX "_P,1,63),0))
- . K:PTR ORDIALOG(PTR,1),ORDIALOG(PTR,"S") ; kill value,screen
- Q
- ;
- MATCH(CATG) ; -- Category match pt location type?
- I $G(OREVENT) Q 1 ; location will be stuffed
- N TYPE,SCREEN,Y S TYPE=$P($G(^SC(+$G(ORL),0)),U,3),Y=1
- S:CATG="I"&(TYPE'="W") SCREEN="I $P(^(0),U,3)=""W"",'$P($G(^(""OOS"")),""^"")"
- S:CATG="O"&(TYPE="W") SCREEN="I $P(^(0),U,3)'=""W"",'$P($G(^(""OOS"")),""^"")"
- I $D(SCREEN) S Y=0,ORDIALOG($$PTR^ORCD("OR GTX LOCATION"),"S")=SCREEN
- Q Y
- ;
- SCHEDULD() ; -- Returns 1 or 0, if patient is scheduled for pre-op
- N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
- I $G(ORDIALOG(PROMPT,1)) Q 1 ; don't ask - already have date
- S DIR(0)="YAO",DIR("A")="Is this patient scheduled for pre-op? "
- S DIR("B")="NO" D ^DIR S:$D(DTOUT)!($D(DUOUT)) ORQUIT=1
- Q +Y
- ;
- MODE() ; -- Returns default mode of transport
- Q:$G(ORTYPE)="Z" "" N I,M,P
- S I=0,M=$O(^ORD(101.41,"AB","OR GTX MODIFIERS",0))
- S P=$O(^RAMIS(71.2,"B","PORTABLE EXAM",0))
- F S I=$O(ORDIALOG(M,I)) Q:I'>0 I ORDIALOG(M,I)=P S Y="P" Q
- S:'$D(Y) Y=$S($G(ORWARD):"W",1:"A")
- Q Y
- ;
- ILOC ; -- Get allowable imaging locations
- N ITYPE,ORY,IFN,CNT K ORDIALOG(PROMPT,"LIST")
- S ITYPE=$P(ORDG,U,4) D EN4^RAO7PC1(ITYPE,"ORY")
- S (IFN,CNT)=0 F S IFN=$O(ORY(IFN)) Q:IFN'>0 D
- . S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=ORY(IFN)_U_IFN
- . S ORDIALOG(PROMPT,"LIST","B",$P(ORY(IFN),U,2))=IFN
- S:CNT ORDIALOG(PROMPT,"LIST")=CNT_"^1",Y=+ORDIALOG(PROMPT,"LIST",1)
- Q
- ;
- DEFLOC() ; -- Returns default imaging location
- N X,I S X=+$G(ORDIALOG(PROMPT,"LIST",1))
- I $G(ORDIV) S I=0 F S I=$O(ORDIALOG(PROMPT,"LIST",I)) Q:I'>0 I $P(ORDIALOG(PROMPT,"LIST",I),U,3)=ORDIV S X=+ORDIALOG(PROMPT,"LIST",I) Q
- Q X
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCDRA1 2965 printed Jan 18, 2025@03:29:24 Page 2
- ORCDRA1 ;SLC/MKB-Utility functions for RA dialogs ; 08 May 2002 2:12 PM
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,75,141**;Dec 17, 1997
- DIV() ; -- Returns division of ordering location
- +1 NEW Y
- IF $GET(ORL)
- IF '$GET(OREVENT)
- SET Y=+$PIECE($GET(^SC(+ORL,0)),U,15)
- SET Y=+$$SITE^VASITE(DT,Y)
- +2 IF $GET(OREVENT)
- SET Y=+$$DIV^OREVNTX(OREVENT)
- +3 if $GET(Y)'>0
- SET Y=+$GET(DUZ(2))
- DIVQ QUIT Y
- +1 ;
- CKPTYPE ; -- Check procedure for Series type
- +1 NEW PTYPE
- SET PTYPE=$PIECE($GET(^ORD(101.43,+$$VAL^ORCD("PROCEDURE"),"RA")),U,2)
- +2 if PTYPE'="S"
- QUIT
- if '$LENGTH($PIECE($GET(^RAMIS(71.2,+Y,0)),U,2))
- QUIT
- +3 WRITE $CHAR(7),!,"This procedure modifier may not be selected with a procedure series!",!
- +4 KILL DONE,ORDIALOG(PROMPT,ORI)
- +5 QUIT
- +6 ;
- VALIDWP(ROOT) ; -- Validate wp field (borrowed from VALWP^RAUTL5)
- +1 ; Pass back '1' is data is valid, '0' if not valid.
- +2 if '$LENGTH($GET(ROOT))
- QUIT 0
- if '$ORDER(@(ROOT_"0)"))
- QUIT 0
- +3 NEW CHAR,CNT,WL,WPFLG,X,Y,Z
- +4 SET (WPFLG,X)=0
- +5 FOR
- SET X=$ORDER(@(ROOT_X_")"))
- if X'>0
- QUIT
- Begin DoDot:1
- +6 SET (CNT,WL)=0
- +7 SET Y=$GET(@(ROOT_X_",0)"))
- if Y']""
- QUIT
- +8 SET WL=$LENGTH(Y)
- +9 FOR Z=1:1:WL
- Begin DoDot:2
- +10 SET CHAR=$EXTRACT(Y,Z)
- if CHAR?1AN
- SET CNT=CNT+1
- +11 if CHAR'?1AN&(CNT>0)
- SET CNT=0
- if CNT=2
- SET WPFLG=1
- End DoDot:2
- if WPFLG
- QUIT
- End DoDot:1
- if WPFLG
- QUIT
- +12 QUIT WPFLG
- +13 ;
- CHNGCAT ; -- Kill dependent values if Category changes
- +1 NEW P,PTR
- +2 FOR P="LOCATION","CONTRACT/SHARING SOURCE","RESEARCH SOURCE"
- Begin DoDot:1
- +3 SET PTR=+$ORDER(^ORD(101.41,"AB",$EXTRACT("OR GTX "_P,1,63),0))
- +4 ; kill value,screen
- if PTR
- KILL ORDIALOG(PTR,1),ORDIALOG(PTR,"S")
- End DoDot:1
- +5 QUIT
- +6 ;
- MATCH(CATG) ; -- Category match pt location type?
- +1 ; location will be stuffed
- IF $GET(OREVENT)
- QUIT 1
- +2 NEW TYPE,SCREEN,Y
- SET TYPE=$PIECE($GET(^SC(+$GET(ORL),0)),U,3)
- SET Y=1
- +3 if CATG="I"&(TYPE'="W")
- SET SCREEN="I $P(^(0),U,3)=""W"",'$P($G(^(""OOS"")),""^"")"
- +4 if CATG="O"&(TYPE="W")
- SET SCREEN="I $P(^(0),U,3)'=""W"",'$P($G(^(""OOS"")),""^"")"
- +5 IF $DATA(SCREEN)
- SET Y=0
- SET ORDIALOG($$PTR^ORCD("OR GTX LOCATION"),"S")=SCREEN
- +6 QUIT Y
- +7 ;
- SCHEDULD() ; -- Returns 1 or 0, if patient is scheduled for pre-op
- +1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
- +2 ; don't ask - already have date
- IF $GET(ORDIALOG(PROMPT,1))
- QUIT 1
- +3 SET DIR(0)="YAO"
- SET DIR("A")="Is this patient scheduled for pre-op? "
- +4 SET DIR("B")="NO"
- DO ^DIR
- if $DATA(DTOUT)!($DATA(DUOUT))
- SET ORQUIT=1
- +5 QUIT +Y
- +6 ;
- MODE() ; -- Returns default mode of transport
- +1 if $GET(ORTYPE)="Z"
- QUIT ""
- NEW I,M,P
- +2 SET I=0
- SET M=$ORDER(^ORD(101.41,"AB","OR GTX MODIFIERS",0))
- +3 SET P=$ORDER(^RAMIS(71.2,"B","PORTABLE EXAM",0))
- +4 FOR
- SET I=$ORDER(ORDIALOG(M,I))
- if I'>0
- QUIT
- IF ORDIALOG(M,I)=P
- SET Y="P"
- QUIT
- +5 if '$DATA(Y)
- SET Y=$SELECT($GET(ORWARD):"W",1:"A")
- +6 QUIT Y
- +7 ;
- ILOC ; -- Get allowable imaging locations
- +1 NEW ITYPE,ORY,IFN,CNT
- KILL ORDIALOG(PROMPT,"LIST")
- +2 SET ITYPE=$PIECE(ORDG,U,4)
- DO EN4^RAO7PC1(ITYPE,"ORY")
- +3 SET (IFN,CNT)=0
- FOR
- SET IFN=$ORDER(ORY(IFN))
- if IFN'>0
- QUIT
- Begin DoDot:1
- +4 SET CNT=CNT+1
- SET ORDIALOG(PROMPT,"LIST",CNT)=ORY(IFN)_U_IFN
- +5 SET ORDIALOG(PROMPT,"LIST","B",$PIECE(ORY(IFN),U,2))=IFN
- End DoDot:1
- +6 if CNT
- SET ORDIALOG(PROMPT,"LIST")=CNT_"^1"
- SET Y=+ORDIALOG(PROMPT,"LIST",1)
- +7 QUIT
- +8 ;
- DEFLOC() ; -- Returns default imaging location
- +1 NEW X,I
- SET X=+$GET(ORDIALOG(PROMPT,"LIST",1))
- +2 IF $GET(ORDIV)
- SET I=0
- FOR
- SET I=$ORDER(ORDIALOG(PROMPT,"LIST",I))
- if I'>0
- QUIT
- IF $PIECE(ORDIALOG(PROMPT,"LIST",I),U,3)=ORDIV
- SET X=+ORDIALOG(PROMPT,"LIST",I)
- QUIT
- +3 QUIT X