- ORWPT16 ; SLC/KCM - Patient Lookup Functions - 16bit ;7/20/96 15:43
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242
- ;
- IDINFO(ORY,DFN) ; Return identifying information for a patient
- ; PID^DOB^AGE^SEX^SC%^TYPE^WARD^RM-BED^NAME
- N OR0,OR36,OR1,OR101,VAEL,VAERR
- S OR0=$G(^DPT(DFN,0)),OR36=$G(^(.36)),OR1=$G(^(.1)),OR101=$G(^(.101))
- D ELIG^VADPT
- S ORY=$P(OR36,U,3)_U_$P(OR0,U,3)_U_U_$P(OR0,U,2)
- S ORY=ORY_U_$P(VAEL(3),U,2)_U_$P(VAEL(6),U,2)_U_$P(OR1,U)_U_$P(OR101,U)
- I $P(OR0,U,3) S $P(ORY,U,3)=DT-$P(OR0,U,3)\10000
- I '$L($P(ORY,U,1)) D
- . S X=$P(OR0,U,9),$P(ORY,U,1)=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99)
- S $P(ORY,U,9)=$P(OR0,U,1)
- Q
- DEMOG(VAL,DFN) ; procedure
- ; Return common patient demographic info
- ; NAME^SEX^DOB^SSN^WARDID^WARDNAME^RMBED^ADMITTIME^DIED ;^SC%^ELIGTYPE
- S X=^DPT(DFN,0),VAL=$P(X,U,1,3)_U_$P(X,U,9)_U_U_$G(^(.1))_U_$G(^(.101))
- S X=$P(VAL,U,6) I $L(X) S $P(VAL,U,5)=$O(^SC("B",X,0))
- S X=$G(^DPT(DFN,.105)) I X S $P(VAL,U,8)=$P(^DGPM(X,0),U,1)
- I $L($P($G(^DPT(DFN,.35)),U,1)) S $P(VAL,U,9)=$P(^(.35),U,1)
- Q
- PSCNVT(VAL,DFN) ; procedure
- ; Call conversion routine for pharmacy (both inpatient and outpatient)
- S VAL=0
- Q
- LISTALL(Y,DIR,FROM) ; Return a bolus of patient names
- N I,IEN,CNT S CNT=44,I=0
- ;
- I DIR=0 D ; Forward direction
- . F S FROM=$O(^DPT("B",FROM)) Q:FROM="" D Q:I=CNT
- . . S IEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT
- . . . ; S X=$P($G(^DPT(IEN,0)),"^",9)
- . . . ; S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99)
- . . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101))
- . . . S I=I+1 S Y(I)=IEN_"^"_FROM ;_"^"_X ; _"^"_X1 ;" ("_X_")"
- . I $G(Y(CNT))="" S I=I+1,Y(I)=""
- ;
- I DIR=1 D ; Reverse direction
- . F S FROM=$O(^DPT("B",FROM),-1) Q:FROM="" D Q:I=CNT
- . . S IEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT
- . . . ; S X=$P($G(^DPT(IEN,0)),"^",9)
- . . . ; S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99)
- . . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101))
- . . . S I=I+1 S Y(I)=IEN_"^"_FROM ;_"^"_X ; _"^"_X1 ;" ("_X_")"
- Q
- LOOKUP(Y,FROM) ; Return a set of patient names
- N I,X
- D FIND^DIC(2,"","","M",FROM)
- S I=0,Y=""
- F S I=$O(^TMP("DILIST",$J,1,I)) Q:'I D
- . S X=^TMP("DILIST",$J,"ID",I,.09)
- . S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99)
- . S Y(I)=^TMP("DILIST",$J,2,I)_"^"_^TMP("DILIST",$J,1,I)_"^"_X
- K ^TMP("DILIST",$J)
- Q
- GETVSIT(Y,DFN,LOC,ADATE) ; procedure
- ; Return a visit given a patient, location, and date/time
- N VSIT,VSITPKG
- S (VSIT,VSIT("VDT"))=ADATE,VSIT("PAT")=DFN,VSIT("LOC")=LOC
- S VSIT("SVC")="A",VSIT("PRI")="P",VSIT(0)="NMD1",VSITPKG="OR"
- D ^VSIT
- S Y=VSIT("IEN") I +VSIT("IEN")'>0 S Y="" Q
- I +VSIT("LOC") S Y=Y_U_VSIT("LOC")_U_$P(^SC(+VSIT("LOC"),0),U,1,2)
- Q
- APPTLST(LST,DFN) ; procedure
- ; Return a list of appointments
- N I,ILST S ILST=0
- D GETAPPT^TIUVSIT(DFN)
- S I=0 F S I=$O(^TMP("TIUVNI",$J,I)) Q:'I D
- . S ILST=ILST+1
- . S LST(ILST)=$P(^TMP("TIUVNI",$J,I),U,1,2)_U_$P(^TMP("TIUVN",$J,I),U,1,2)
- K ^TMP("TIUVN",$J),^TMP("TIUVNI",$J)
- Q
- ADMITLST(LST,DFN) ; procedure
- ; Return a list of admissions
- N TIM,MOV,X0,Y,MTIM,XTIM,XTYP,XLOC,HLOC,ILST S ILST=0
- S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D
- . S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D
- . . S X0=^DGPM(MOV,0)
- . . S MTIM=$P(X0,U,1),Y=MTIM D DD^%DT S XTIM=Y
- . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1)
- . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44))
- . . S ILST=ILST+1,LST(ILST)=MTIM_U_HLOC_U_XTIM_U_XTYP_U_"TO: "_XLOC
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWPT16 3553 printed Feb 19, 2025@00:03:44 Page 2
- ORWPT16 ; SLC/KCM - Patient Lookup Functions - 16bit ;7/20/96 15:43
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242
- +2 ;
- IDINFO(ORY,DFN) ; Return identifying information for a patient
- +1 ; PID^DOB^AGE^SEX^SC%^TYPE^WARD^RM-BED^NAME
- +2 NEW OR0,OR36,OR1,OR101,VAEL,VAERR
- +3 SET OR0=$GET(^DPT(DFN,0))
- SET OR36=$GET(^(.36))
- SET OR1=$GET(^(.1))
- SET OR101=$GET(^(.101))
- +4 DO ELIG^VADPT
- +5 SET ORY=$PIECE(OR36,U,3)_U_$PIECE(OR0,U,3)_U_U_$PIECE(OR0,U,2)
- +6 SET ORY=ORY_U_$PIECE(VAEL(3),U,2)_U_$PIECE(VAEL(6),U,2)_U_$PIECE(OR1,U)_U_$PIECE(OR101,U)
- +7 IF $PIECE(OR0,U,3)
- SET $PIECE(ORY,U,3)=DT-$PIECE(OR0,U,3)\10000
- +8 IF '$LENGTH($PIECE(ORY,U,1))
- Begin DoDot:1
- +9 SET X=$PIECE(OR0,U,9)
- SET $PIECE(ORY,U,1)=$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,99)
- End DoDot:1
- +10 SET $PIECE(ORY,U,9)=$PIECE(OR0,U,1)
- +11 QUIT
- DEMOG(VAL,DFN) ; procedure
- +1 ; Return common patient demographic info
- +2 ; NAME^SEX^DOB^SSN^WARDID^WARDNAME^RMBED^ADMITTIME^DIED ;^SC%^ELIGTYPE
- +3 SET X=^DPT(DFN,0)
- SET VAL=$PIECE(X,U,1,3)_U_$PIECE(X,U,9)_U_U_$GET(^(.1))_U_$GET(^(.101))
- +4 SET X=$PIECE(VAL,U,6)
- IF $LENGTH(X)
- SET $PIECE(VAL,U,5)=$ORDER(^SC("B",X,0))
- +5 SET X=$GET(^DPT(DFN,.105))
- IF X
- SET $PIECE(VAL,U,8)=$PIECE(^DGPM(X,0),U,1)
- +6 IF $LENGTH($PIECE($GET(^DPT(DFN,.35)),U,1))
- SET $PIECE(VAL,U,9)=$PIECE(^(.35),U,1)
- +7 QUIT
- PSCNVT(VAL,DFN) ; procedure
- +1 ; Call conversion routine for pharmacy (both inpatient and outpatient)
- +2 SET VAL=0
- +3 QUIT
- LISTALL(Y,DIR,FROM) ; Return a bolus of patient names
- +1 NEW I,IEN,CNT
- SET CNT=44
- SET I=0
- +2 ;
- +3 ; Forward direction
- IF DIR=0
- Begin DoDot:1
- +4 FOR
- SET FROM=$ORDER(^DPT("B",FROM))
- if FROM=""
- QUIT
- Begin DoDot:2
- +5 SET IEN=0
- FOR
- SET IEN=$ORDER(^DPT("B",FROM,IEN))
- if 'IEN
- QUIT
- Begin DoDot:3
- +6 ; S X=$P($G(^DPT(IEN,0)),"^",9)
- +7 ; S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99)
- +8 ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101))
- +9 ;_"^"_X ; _"^"_X1 ;" ("_X_")"
- SET I=I+1
- SET Y(I)=IEN_"^"_FROM
- End DoDot:3
- if I=CNT
- QUIT
- End DoDot:2
- if I=CNT
- QUIT
- +10 IF $GET(Y(CNT))=""
- SET I=I+1
- SET Y(I)=""
- End DoDot:1
- +11 ;
- +12 ; Reverse direction
- IF DIR=1
- Begin DoDot:1
- +13 FOR
- SET FROM=$ORDER(^DPT("B",FROM),-1)
- if FROM=""
- QUIT
- Begin DoDot:2
- +14 SET IEN=0
- FOR
- SET IEN=$ORDER(^DPT("B",FROM,IEN))
- if 'IEN
- QUIT
- Begin DoDot:3
- +15 ; S X=$P($G(^DPT(IEN,0)),"^",9)
- +16 ; S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99)
- +17 ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101))
- +18 ;_"^"_X ; _"^"_X1 ;" ("_X_")"
- SET I=I+1
- SET Y(I)=IEN_"^"_FROM
- End DoDot:3
- if I=CNT
- QUIT
- End DoDot:2
- if I=CNT
- QUIT
- End DoDot:1
- +19 QUIT
- LOOKUP(Y,FROM) ; Return a set of patient names
- +1 NEW I,X
- +2 DO FIND^DIC(2,"","","M",FROM)
- +3 SET I=0
- SET Y=""
- +4 FOR
- SET I=$ORDER(^TMP("DILIST",$JOB,1,I))
- if 'I
- QUIT
- Begin DoDot:1
- +5 SET X=^TMP("DILIST",$JOB,"ID",I,.09)
- +6 SET X=$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,99)
- +7 SET Y(I)=^TMP("DILIST",$JOB,2,I)_"^"_^TMP("DILIST",$JOB,1,I)_"^"_X
- End DoDot:1
- +8 KILL ^TMP("DILIST",$JOB)
- +9 QUIT
- GETVSIT(Y,DFN,LOC,ADATE) ; procedure
- +1 ; Return a visit given a patient, location, and date/time
- +2 NEW VSIT,VSITPKG
- +3 SET (VSIT,VSIT("VDT"))=ADATE
- SET VSIT("PAT")=DFN
- SET VSIT("LOC")=LOC
- +4 SET VSIT("SVC")="A"
- SET VSIT("PRI")="P"
- SET VSIT(0)="NMD1"
- SET VSITPKG="OR"
- +5 DO ^VSIT
- +6 SET Y=VSIT("IEN")
- IF +VSIT("IEN")'>0
- SET Y=""
- QUIT
- +7 IF +VSIT("LOC")
- SET Y=Y_U_VSIT("LOC")_U_$PIECE(^SC(+VSIT("LOC"),0),U,1,2)
- +8 QUIT
- APPTLST(LST,DFN) ; procedure
- +1 ; Return a list of appointments
- +2 NEW I,ILST
- SET ILST=0
- +3 DO GETAPPT^TIUVSIT(DFN)
- +4 SET I=0
- FOR
- SET I=$ORDER(^TMP("TIUVNI",$JOB,I))
- if 'I
- QUIT
- Begin DoDot:1
- +5 SET ILST=ILST+1
- +6 SET LST(ILST)=$PIECE(^TMP("TIUVNI",$JOB,I),U,1,2)_U_$PIECE(^TMP("TIUVN",$JOB,I),U,1,2)
- End DoDot:1
- +7 KILL ^TMP("TIUVN",$JOB),^TMP("TIUVNI",$JOB)
- +8 QUIT
- ADMITLST(LST,DFN) ; procedure
- +1 ; Return a list of admissions
- +2 NEW TIM,MOV,X0,Y,MTIM,XTIM,XTYP,XLOC,HLOC,ILST
- SET ILST=0
- +3 SET TIM=""
- FOR
- SET TIM=$ORDER(^DGPM("ATID1",DFN,TIM))
- if TIM'>0
- QUIT
- Begin DoDot:1
- +4 SET MOV=0
- FOR
- SET MOV=$ORDER(^DGPM("ATID1",DFN,TIM,MOV))
- if MOV'>0
- QUIT
- Begin DoDot:2
- +5 SET X0=^DGPM(MOV,0)
- +6 SET MTIM=$PIECE(X0,U,1)
- SET Y=MTIM
- DO DD^%DT
- SET XTIM=Y
- +7 SET XTYP=$PIECE($GET(^DG(405.1,+$PIECE(X0,U,4),0)),U,1)
- +8 SET XLOC=$PIECE($GET(^DIC(42,+$PIECE(X0,U,6),0)),U,1)
- SET HLOC=+$GET(^(44))
- +9 SET ILST=ILST+1
- SET LST(ILST)=MTIM_U_HLOC_U_XTIM_U_XTYP_U_"TO: "_XLOC
- End DoDot:2
- End DoDot:1
- +10 QUIT