ORWU16 ; SLC/KCM - General Utilites for Windows Calls 16bit
;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
;
USERINFO(Y) ; procedure
; return DUZ^NAME^SIGNAUTH^ISPROVIDER for the current user
; I DUZ=1085 S DUZ=1298 ; CHANGE ID **** DON'T EXPORT ****
S Y=DUZ_U_$P(^VA(200,DUZ,0),U,1)
S $P(Y,U,3)=$S($D(^XUSEC("ORES",DUZ)):3,$D(^XUSEC("ORELSE",DUZ)):2,$D(^XUSEC("OREMAS",DUZ)):1,1:0)
S $P(Y,U,4)=$D(^XUSEC("PROVIDER",DUZ))#10
Q
VALIDSIG(ESOK,X) ; procedure
S X=$$DECRYP^XUSRB1(X),ESOK=0
D HASH^XUSHSHP
I X=$P($G(^VA(200,+DUZ,20)),U,4) S ESOK=1
Q
HOSPLOC(Y,DIR,FROM) ; Return a bolus from the HOSPITAL LOCATION file
; .Return Array, Direction, Starting Text
N I,IEN,CNT S CNT=44
;
I DIR=0 D ; Forward direction
. F I=1:1:CNT S FROM=$O(^SC("B",FROM)) Q:FROM="" D
. . S IEN=$O(^SC("B",FROM,0))
. . I $$ACTLOC(IEN) S Y(I)=IEN_"^"_FROM
. I $G(Y(CNT))="" S Y(I)=""
;
I DIR=1 D ; Reverse direction
. F I=1:1:CNT S FROM=$O(^SC("B",FROM),-1) Q:FROM="" D
. . S IEN=$O(^SC("B",FROM,0))
. . I $$ACTLOC(IEN) S Y(I)=IEN_"^"_FROM
Q
ACTLOC(LOC) ; Function
; Returns 1 (true) if active hospital location, otherwise 0 (false)
N D0,X I +$G(^SC(LOC,"OOS")) Q 0 ; screen out OOS entry
S D0=+$G(^SC(LOC,42)) I D0 D WIN^DGPMDDCF Q 'X ; chk out of svc wards
S X=$G(^SC(LOC,"I")) I +X=0 Q 1 ; no inactivate date
I DT>$P(X,U)&($P(X,U,2)=""!(DT<$P(X,U,2))) Q 0 ; chk reactivate date
Q 1 ; must still be active
;
NEWPERS(Y,DIR,FROM,KEY) ; Return a bolus from the NEW PERSON file
; .Return Array, Direction, Starting Text
N I,IEN,CNT S CNT=44,KEY=$G(KEY)
;
I DIR=0 D ; Forward direction
. F I=1:1:CNT S FROM=$O(^VA(200,"B",FROM)) Q:FROM="" D
. . S IEN=$O(^VA(200,"B",FROM,0)) I $L(KEY),'$D(^XUSEC(KEY,IEN)) Q
. . S Y(I)=IEN_"^"_FROM
. I $G(Y(CNT))="" S Y(I)=""
;
I DIR=1 D ; Reverse direction
. F I=1:1:CNT S FROM=$O(^VA(200,"B",FROM),-1) Q:FROM="" D
. . S IEN=$O(^VA(200,"B",FROM,0)) I $L(KEY),'$D(^XUSEC(KEY,IEN)) Q
. . S Y(I)=IEN_"^"_FROM
Q
DEVICE(Y) ; Return a list of devices
S I=0,DEV=""
F S DEV=$O(^%ZIS(1,"B",DEV)) Q:DEV="" S IEN=$O(^(DEV,0)) D
. I $E($G(^%ZIS(2,+$G(^%ZIS(1,IEN,"SUBTYPE")),0)))'="P" Q
. I $P($G(^%ZIS(1,IEN,0)),U,12)=2 Q
. S I=I+1,Y(I)=IEN_";"_$P(^%ZIS(1,IEN,0),U)_U_DEV_U_$P($G(^(1)),U)_U_$P($G(^(90)),U)_U_$P(^(91),U)_U_$P(^(91),U,3)
Q
VALDT(Y,X,%DT) ; Validate date/time entry
S:'$D(%DT) %DT="TX" D ^%DT
Q
;
URGENCY(Y) ; -- retrieve set values from dd for discharge summary urgency
N ORDD,I,X
D FIELD^DID(8925,.09,"","POINTER","ORDD")
F I=1:1 S X=$P(ORDD("POINTER"),";",I) Q:X="" S Y(I)=$TR(X,":","^")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWU16 2738 printed Oct 16, 2024@18:38:16 Page 2
ORWU16 ; SLC/KCM - General Utilites for Windows Calls 16bit
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
+2 ;
USERINFO(Y) ; procedure
+1 ; return DUZ^NAME^SIGNAUTH^ISPROVIDER for the current user
+2 ; I DUZ=1085 S DUZ=1298 ; CHANGE ID **** DON'T EXPORT ****
+3 SET Y=DUZ_U_$PIECE(^VA(200,DUZ,0),U,1)
+4 SET $PIECE(Y,U,3)=$SELECT($DATA(^XUSEC("ORES",DUZ)):3,$DATA(^XUSEC("ORELSE",DUZ)):2,$DATA(^XUSEC("OREMAS",DUZ)):1,1:0)
+5 SET $PIECE(Y,U,4)=$DATA(^XUSEC("PROVIDER",DUZ))#10
+6 QUIT
VALIDSIG(ESOK,X) ; procedure
+1 SET X=$$DECRYP^XUSRB1(X)
SET ESOK=0
+2 DO HASH^XUSHSHP
+3 IF X=$PIECE($GET(^VA(200,+DUZ,20)),U,4)
SET ESOK=1
+4 QUIT
HOSPLOC(Y,DIR,FROM) ; Return a bolus from the HOSPITAL LOCATION file
+1 ; .Return Array, Direction, Starting Text
+2 NEW I,IEN,CNT
SET CNT=44
+3 ;
+4 ; Forward direction
IF DIR=0
Begin DoDot:1
+5 FOR I=1:1:CNT
SET FROM=$ORDER(^SC("B",FROM))
if FROM=""
QUIT
Begin DoDot:2
+6 SET IEN=$ORDER(^SC("B",FROM,0))
+7 IF $$ACTLOC(IEN)
SET Y(I)=IEN_"^"_FROM
End DoDot:2
+8 IF $GET(Y(CNT))=""
SET Y(I)=""
End DoDot:1
+9 ;
+10 ; Reverse direction
IF DIR=1
Begin DoDot:1
+11 FOR I=1:1:CNT
SET FROM=$ORDER(^SC("B",FROM),-1)
if FROM=""
QUIT
Begin DoDot:2
+12 SET IEN=$ORDER(^SC("B",FROM,0))
+13 IF $$ACTLOC(IEN)
SET Y(I)=IEN_"^"_FROM
End DoDot:2
End DoDot:1
+14 QUIT
ACTLOC(LOC) ; Function
+1 ; Returns 1 (true) if active hospital location, otherwise 0 (false)
+2 ; screen out OOS entry
NEW D0,X
IF +$GET(^SC(LOC,"OOS"))
QUIT 0
+3 ; chk out of svc wards
SET D0=+$GET(^SC(LOC,42))
IF D0
DO WIN^DGPMDDCF
QUIT 'X
+4 ; no inactivate date
SET X=$GET(^SC(LOC,"I"))
IF +X=0
QUIT 1
+5 ; chk reactivate date
IF DT>$PIECE(X,U)&($PIECE(X,U,2)=""!(DT<$PIECE(X,U,2)))
QUIT 0
+6 ; must still be active
QUIT 1
+7 ;
NEWPERS(Y,DIR,FROM,KEY) ; Return a bolus from the NEW PERSON file
+1 ; .Return Array, Direction, Starting Text
+2 NEW I,IEN,CNT
SET CNT=44
SET KEY=$GET(KEY)
+3 ;
+4 ; Forward direction
IF DIR=0
Begin DoDot:1
+5 FOR I=1:1:CNT
SET FROM=$ORDER(^VA(200,"B",FROM))
if FROM=""
QUIT
Begin DoDot:2
+6 SET IEN=$ORDER(^VA(200,"B",FROM,0))
IF $LENGTH(KEY)
IF '$DATA(^XUSEC(KEY,IEN))
QUIT
+7 SET Y(I)=IEN_"^"_FROM
End DoDot:2
+8 IF $GET(Y(CNT))=""
SET Y(I)=""
End DoDot:1
+9 ;
+10 ; Reverse direction
IF DIR=1
Begin DoDot:1
+11 FOR I=1:1:CNT
SET FROM=$ORDER(^VA(200,"B",FROM),-1)
if FROM=""
QUIT
Begin DoDot:2
+12 SET IEN=$ORDER(^VA(200,"B",FROM,0))
IF $LENGTH(KEY)
IF '$DATA(^XUSEC(KEY,IEN))
QUIT
+13 SET Y(I)=IEN_"^"_FROM
End DoDot:2
End DoDot:1
+14 QUIT
DEVICE(Y) ; Return a list of devices
+1 SET I=0
SET DEV=""
+2 FOR
SET DEV=$ORDER(^%ZIS(1,"B",DEV))
if DEV=""
QUIT
SET IEN=$ORDER(^(DEV,0))
Begin DoDot:1
+3 IF $EXTRACT($GET(^%ZIS(2,+$GET(^%ZIS(1,IEN,"SUBTYPE")),0)))'="P"
QUIT
+4 IF $PIECE($GET(^%ZIS(1,IEN,0)),U,12)=2
QUIT
+5 SET I=I+1
SET Y(I)=IEN_";"_$PIECE(^%ZIS(1,IEN,0),U)_U_DEV_U_$PIECE($GET(^(1)),U)_U_$PIECE($GET(^(90)),U)_U_$PIECE(^(91),U)_U_$PIECE(^(91),U,3)
End DoDot:1
+6 QUIT
VALDT(Y,X,%DT) ; Validate date/time entry
+1 if '$DATA(%DT)
SET %DT="TX"
DO ^%DT
+2 QUIT
+3 ;
URGENCY(Y) ; -- retrieve set values from dd for discharge summary urgency
+1 NEW ORDD,I,X
+2 DO FIELD^DID(8925,.09,"","POINTER","ORDD")
+3 FOR I=1:1
SET X=$PIECE(ORDD("POINTER"),";",I)
if X=""
QUIT
SET Y(I)=$TRANSLATE(X,":","^")
+4 QUIT
+5 ;
