- ADGPMV10 ; IHS/ADC/PDW/ENM - PATIENT MOVEMENT, CONT. ; [ 09/17/2002 4:01 PM ]
- ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- ;;MAS VERSION 5.0;
- ;IHS/ANMC/RAM,LJF;
- ; -- changed comment for no inpt activity
- ; -- moved placement of items and removed those not used by IHS
- ;IHS/HQW/WAR renamed to allow use with v5.3 DaySurgery
- ;
- CS ;Current Status
- S X=$S('DGPMT:1,DGPMT<4:2,DGPMT>5:2,1:3) ;DGPMT=0 if from pt inq (DGRPD)
- I $O(^DPT(DFN,"DA",0)) W !!,"***NOTE*** This patient has not been converted into the new file structure.",!," Inpatient data for this patient is not yet available.",! Q
- ;I '$D(^DGPM("C",DFN)) W !!,"Status : PATIENT HAS NO INPATIENT OR LODGER ACTIVITY IN THE COMPUTER",*7 D CS2 Q ;IHS orig
- I '$D(^DGPM("C",DFN)) D Q ;IHS chgd
- . W !!,"Inpatient Status: NO ACTIVITY RECORDED IN COMPUTER" D CS2 ;IHS chgd
- ;S A=$S("^3^5^"[("^"_+DGPMVI(2)_"^"):0,1:+DGPMVI(2)) W !!,"Status : ",$S('A:"IN",1:""),"ACTIVE ",$S("^4^5^"[("^"_+DGPMVI(2)_"^"):"LODGER",1:"INPATIENT") ;IHS orig
- S A=$S("^3^5^"[("^"_+DGPMVI(2)_"^"):0,1:+DGPMVI(2)) W !!,"Inpatient Status: ",$S('A:"IN",1:""),"ACTIVE ",$S("^4^5^"[("^"_+DGPMVI(2)_"^"):"LODGER",1:"INPATIENT") ;IHS chgd
- G CS1:'A W "-" S X=+DGPMVI(4) I X=1 W "on PASS" G CS1
- I "^2^3^25^26^"[("^"_X_"^") W "on ",$S("^2^26^"[X:"A",1:"U"),"A" G CS1
- I "^13^43^44^45^"[("^"_X_"^") W "ASIH" G CS1
- I X=6 W "OTHER FAC" G CS1
- ;W "on WARD" ;IHS
- W "on WARD" D IHS ;IHS
- CS1 I +DGPMVI(2)=3,$D(^DGPM(+DGPMVI(17),0)) W ?39,"Discharge Type : ",$S($D(^DG(405.1,+$P(^(0),"^",4),0)):$P(^(0),"^",1),1:"UNKNOWN")
- I "^3^4^5^"'[("^"_+DGPMVI(2)_"^"),$D(^DPT(DFN,"DAC")),($P(^("DAC"),"^",1)="S") W " (Seriously ill)"
- W !!,$S("^4^5^"'[("^"_+DGPMVI(2)_"^"):"Admitted ",1:"Checked-in "),": "_$P(DGPMVI(13,1),"^",2)
- W ?39,$S("^4^5^"[("^"_+DGPMVI(2)_"^"):"Checked-out",+DGPMVI(2)=3:"Discharged ",1:"Transferred")," : ",$S("^1^4^"'[("^"_+DGPMVI(2)_"^"):$P(DGPMVI(3),"^",2),$P(DGPMVI(3),"^",2)'=$P(DGPMVI(13,1),"^",2):$P(DGPMVI(3),"^",2),1:"")
- W !,"Ward : ",$E($P(DGPMVI(5),"^",2),1,26),?39,"Room-Bed : ",$E($P(DGPMVI(6),"^",2),1,26) I "^4^5^"'[("^"_+DGPMVI(2)_"^") W !,"Provider : ",$E($P(DGPMVI(7),"^",2),1,26),?39,"Specialty : ",$E($P(DGPMVI(8),"^",2),1,26)
- D CS2
- ;S DGPMIFN=DGPMVI(13) I +DGPMVI(2)'=4&(+DGPMVI(2)'=5) D ^DGPMLOS W !!,"Admission LOS: ",+$P(X,"^",5)," Absence days: ",+$P(X,"^",2)," Pass Days: ",+$P(X,"^",3)," ASIH days: ",+$P(X,"^",4) ;IHS
- Q ;IHS
- IHS ; los ;IHS
- ;S DGPMIFN=DGPMVI(13) I +DGPMVI(2)'=4&(+DGPMVI(2)'=5) D ^DGPMLOS W !!,"Admission LOS: ",+$P(X,"^",5) ;IHS
- S DGPMIFN=DGPMVI(13) I +DGPMVI(2)'=4&(+DGPMVI(2)'=5) D ^DGPMLOS W ?45,"Admission LOS: ",+$P(X,"^",5)," days" ;IHS
- K A,C,I,J,X
- Q
- ;
- CS2 ;-- additional fields for admission screen
- Q:DGPMT'=1
- ;IHS removed religion, marital status, & eligibility from adm screen
- ;IHS add here any IHS fields that should be included with adm screen
- Q ;IHS
- S DGHOLD=$S($D(^DPT(DFN,0)):^(0),1:"")
- W !!,"Religion : ",$S($D(^DIC(13,+$P(DGHOLD,U,8),0)):$E($P(^(0),U),1,24),1:"")
- W ?39,"Marital Status : ",$S($D(^DIC(11,+$P(DGHOLD,U,5),0)):$P(^(0),U),1:"")
- S DGHOLD=$S($D(^DPT(DFN,.36)):$P(^(.36),U),1:"")
- W !,"Eligibility : ",$S($D(^DIC(8,+$P(DGHOLD,U),0)):$P(^(0),U),1:"")
- S DGHOLD=$S($D(^DPT(DFN,.361)):^(.361),1:"")
- W:$P(DGHOLD,U)]"" " (",$P($P($P(^DD(2,.3611,0),U,3),$P(DGHOLD,U)_":",2),";"),")"
- W:$P(DGHOLD,U)']"" " (NOT VERIFIED)"
- K DGHOLD
- Q
- ;
- IN5 ; -- calls IN5^VADPT and sets up array
- S VAHOW=2 D IN5^VADPT F I=1:1:8,13,14,17 S DGPMVI(I)=^UTILITY("VAIP",$J,I)
- S DGPMDCD=+^UTILITY("VAIP",$J,17,1) I $D(DGPMSVC) S DGPMSV=$S($D(^DIC(42,+^UTILITY("VAIP",$J,13,4),0)):$P(^(0),"^",3),1:"")
- S DGPMVI(13,1)=^UTILITY("VAIP",$J,13,1) K VAHOW
- Q
- ;
- LODGER ;set-up necessary variables if getting last lodger episode
- ;only need 1,2,13,17 - date/time,TT,check-in IFN,check-out IFN
- S I=$O(^DGPM("ATID4",DFN,I)),I=$O(^(+I,0))
- S X=$S($D(^DGPM(+I,0)):^(0),1:"") I 'X D NULL Q
- I $D(^DGPM(+$P(X,"^",17),0)) S (DGPMDCD,DGPMVI(1))=+^(0),DGPMVI(2)=5,DGPMVI(13)=I,DGPMVI(17)=$P(X,"^",17) Q
- S (DGPMDCD,DGPMVI(17))="",DGPMVI(1)=+X,DGPMVI(2)=4,DGPMVI(13)=I
- Q
- NULL S DGPMDCD="" F I=1,2,13,17 S DGPMVI(I)=""
- Q
- ADGPMV10 ; IHS/ADC/PDW/ENM - PATIENT MOVEMENT, CONT. ; [ 09/17/2002 4:01 PM ]
- +1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- +2 ;;MAS VERSION 5.0;
- +3 ;IHS/ANMC/RAM,LJF;
- +4 ; -- changed comment for no inpt activity
- +5 ; -- moved placement of items and removed those not used by IHS
- +6 ;IHS/HQW/WAR renamed to allow use with v5.3 DaySurgery
- +7 ;
- CS ;Current Status
- +1 ;DGPMT=0 if from pt inq (DGRPD)
- SET X=$SELECT('DGPMT:1,DGPMT<4:2,DGPMT>5:2,1:3)
- +2 IF $ORDER(^DPT(DFN,"DA",0))
- WRITE !!,"***NOTE*** This patient has not been converted into the new file structure.",!," Inpatient data for this patient is not yet available.",!
- QUIT
- +3 ;I '$D(^DGPM("C",DFN)) W !!,"Status : PATIENT HAS NO INPATIENT OR LODGER ACTIVITY IN THE COMPUTER",*7 D CS2 Q ;IHS orig
- +4 ;IHS chgd
- IF '$DATA(^DGPM("C",DFN))
- Begin DoDot:1
- +5 ;IHS chgd
- WRITE !!,"Inpatient Status: NO ACTIVITY RECORDED IN COMPUTER"
- DO CS2
- End DoDot:1
- QUIT
- +6 ;S A=$S("^3^5^"[("^"_+DGPMVI(2)_"^"):0,1:+DGPMVI(2)) W !!,"Status : ",$S('A:"IN",1:""),"ACTIVE ",$S("^4^5^"[("^"_+DGPMVI(2)_"^"):"LODGER",1:"INPATIENT") ;IHS orig
- +7 ;IHS chgd
- SET A=$SELECT("^3^5^"[("^"_+DGPMVI(2)_"^"):0,1:+DGPMVI(2))
- WRITE !!,"Inpatient Status: ",$SELECT('A:"IN",1:""),"ACTIVE ",$SELECT("^4^5^"[("^"_+DGPMVI(2)_"^"):"LODGER",1:"INPATIENT")
- +8 IF 'A
- GOTO CS1
- WRITE "-"
- SET X=+DGPMVI(4)
- IF X=1
- WRITE "on PASS"
- GOTO CS1
- +9 IF "^2^3^25^26^"[("^"_X_"^")
- WRITE "on ",$SELECT("^2^26^"[X:"A",1:"U"),"A"
- GOTO CS1
- +10 IF "^13^43^44^45^"[("^"_X_"^")
- WRITE "ASIH"
- GOTO CS1
- +11 IF X=6
- WRITE "OTHER FAC"
- GOTO CS1
- +12 ;W "on WARD" ;IHS
- +13 ;IHS
- WRITE "on WARD"
- DO IHS
- CS1 IF +DGPMVI(2)=3
- IF $DATA(^DGPM(+DGPMVI(17),0))
- WRITE ?39,"Discharge Type : ",$SELECT($DATA(^DG(405.1,+$PIECE(^(0),"^",4),0)):$PIECE(^(0),"^",1),1:"UNKNOWN")
- +1 IF "^3^4^5^"'[("^"_+DGPMVI(2)_"^")
- IF $DATA(^DPT(DFN,"DAC"))
- IF ($PIECE(^("DAC"),"^",1)="S")
- WRITE " (Seriously ill)"
- +2 WRITE !!,$SELECT("^4^5^"'[("^"_+DGPMVI(2)_"^"):"Admitted ",1:"Checked-in "),": "_$PIECE(DGPMVI(13,1),"^",2)
- +3 WRITE ?39,$SELECT("^4^5^"[("^"_+DGPMVI(2)_"^"):"Checked-out",+DGPMVI(2)=3:"Discharged ",1:"Transferred")," : ",$SELECT("^1^4^"'[("^"_+DGPMVI(2)_"^"):$PIECE(DGPMVI(3),"^",2),$PIECE(DGPMVI(3),"^",2)'=$PIECE(DGPMVI(13,1),"^",2):...
- ... $PIECE(DGPMVI(3),"^",2),1:"")
- +4 WRITE !,"Ward : ",$EXTRACT($PIECE(DGPMVI(5),"^",2),1,26),?39,"Room-Bed : ",$EXTRACT($PIECE(DGPMVI(6),"^",2),1,26)
- IF "^4^5^"'[("^"_+DGPMVI(2)_"^")
- WRITE !,"Provider : ",$EXTRACT($PIECE(DGPMVI(7),"^",2),1,26),?39,"Specialty : ",$EXTRACT($PIECE(DGPMVI(8),"^",2),1,26)
- +5 DO CS2
- +6 ;S DGPMIFN=DGPMVI(13) I +DGPMVI(2)'=4&(+DGPMVI(2)'=5) D ^DGPMLOS W !!,"Admission LOS: ",+$P(X,"^",5)," Absence days: ",+$P(X,"^",2)," Pass Days: ",+$P(X,"^",3)," ASIH days: ",+$P(X,"^",4) ;IHS
- +7 ;IHS
- QUIT
- IHS ; los ;IHS
- +1 ;S DGPMIFN=DGPMVI(13) I +DGPMVI(2)'=4&(+DGPMVI(2)'=5) D ^DGPMLOS W !!,"Admission LOS: ",+$P(X,"^",5) ;IHS
- +2 ;IHS
- SET DGPMIFN=DGPMVI(13)
- IF +DGPMVI(2)'=4&(+DGPMVI(2)'=5)
- DO ^DGPMLOS
- WRITE ?45,"Admission LOS: ",+$PIECE(X,"^",5)," days"
- +3 KILL A,C,I,J,X
- +4 QUIT
- +5 ;
- CS2 ;-- additional fields for admission screen
- +1 IF DGPMT'=1
- QUIT
- +2 ;IHS removed religion, marital status, & eligibility from adm screen
- +3 ;IHS add here any IHS fields that should be included with adm screen
- +4 ;IHS
- QUIT
- +5 SET DGHOLD=$SELECT($DATA(^DPT(DFN,0)):^(0),1:"")
- +6 WRITE !!,"Religion : ",$SELECT($DATA(^DIC(13,+$PIECE(DGHOLD,U,8),0)):$EXTRACT($PIECE(^(0),U),1,24),1:"")
- +7 WRITE ?39,"Marital Status : ",$SELECT($DATA(^DIC(11,+$PIECE(DGHOLD,U,5),0)):$PIECE(^(0),U),1:"")
- +8 SET DGHOLD=$SELECT($DATA(^DPT(DFN,.36)):$PIECE(^(.36),U),1:"")
- +9 WRITE !,"Eligibility : ",$SELECT($DATA(^DIC(8,+$PIECE(DGHOLD,U),0)):$PIECE(^(0),U),1:"")
- +10 SET DGHOLD=$SELECT($DATA(^DPT(DFN,.361)):^(.361),1:"")
- +11 IF $PIECE(DGHOLD,U)]""
- WRITE " (",$PIECE($PIECE($PIECE(^DD(2,.3611,0),U,3),$PIECE(DGHOLD,U)_":",2),";"),")"
- +12 IF $PIECE(DGHOLD,U)']""
- WRITE " (NOT VERIFIED)"
- +13 KILL DGHOLD
- +14 QUIT
- +15 ;
- IN5 ; -- calls IN5^VADPT and sets up array
- +1 SET VAHOW=2
- DO IN5^VADPT
- FOR I=1:1:8,13,14,17
- SET DGPMVI(I)=^UTILITY("VAIP",$JOB,I)
- +2 SET DGPMDCD=+^UTILITY("VAIP",$JOB,17,1)
- IF $DATA(DGPMSVC)
- SET DGPMSV=$SELECT($DATA(^DIC(42,+^UTILITY("VAIP",$JOB,13,4),0)):$PIECE(^(0),"^",3),1:"")
- +3 SET DGPMVI(13,1)=^UTILITY("VAIP",$JOB,13,1)
- KILL VAHOW
- +4 QUIT
- +5 ;
- LODGER ;set-up necessary variables if getting last lodger episode
- +1 ;only need 1,2,13,17 - date/time,TT,check-in IFN,check-out IFN
- +2 SET I=$ORDER(^DGPM("ATID4",DFN,I))
- SET I=$ORDER(^(+I,0))
- +3 SET X=$SELECT($DATA(^DGPM(+I,0)):^(0),1:"")
- IF 'X
- DO NULL
- QUIT
- +4 IF $DATA(^DGPM(+$PIECE(X,"^",17),0))
- SET (DGPMDCD,DGPMVI(1))=+^(0)
- SET DGPMVI(2)=5
- SET DGPMVI(13)=I
- SET DGPMVI(17)=$PIECE(X,"^",17)
- QUIT
- +5 SET (DGPMDCD,DGPMVI(17))=""
- SET DGPMVI(1)=+X
- SET DGPMVI(2)=4
- SET DGPMVI(13)=I
- +6 QUIT
- NULL SET DGPMDCD=""
- FOR I=1,2,13,17
- SET DGPMVI(I)=""
- +1 QUIT
