ADGPI ; IHS/ADC/PDW/ENM - PATIENT INQUIRY ; [ 09/17/2002 4:19 PM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
SP ; -- select patient
N DFN,DIC,Y,X S DIC="^DPT(",DIC(0)="AEQMZ"
D ^DIC K DIC Q:Y'>0 S DFN=+Y D EN G SP
;
EN ;EP; entry point - input DFN
Q:'$D(DFN) D DM,CS,DS,SV,FA,KVA^VADPT,IN,PG Q
;
DM ; -- demographic data
N DGDPTN0,DGDPTN11,DGDPTN13,DGPATN0,DGPATN11
S DGDPTN0=^DPT(DFN,0),DGDPTN11=$G(^(.11)),DGDPTN13=$G(^(.13))
S DGPATN0=$G(^AUPNPAT(DFN,0)),DGPATN11=$G(^(11))
W !!?13,"***Confidential Patient Data Covered by Privacy Act***"
W !!,$P(DGDPTN0,U),?32,"HRCN: ",$$HRCN^ADGF,?54,"DOB: ",$$DOB
W !,$P(DGDPTN11,U),?31,"PHONE: ",$P(DGDPTN13,U),?53,"PROV: ",$$PCP
W !,$P(DGDPTN11,U,4)," ",$$ST," ",$P(DGDPTN11,U,6)
W ?32,"ELIG: ",$$ELIG,?54,"SSN: ",$P(DGDPTN0,U,9) Q
;
CS ; -- current status
;D INP^DGRPD Q
D INP^ADGRPD Q ;9/17/02 WAR Modified to allow for v5.3 DaySurgery
;
DS ; -- last day surgery
S X="SRZPEP" X ^%ZOSF("TEST") I $T S DGCK=$$LASTDS^SRZPEP
Q:$G(DGCK)
Q:'$D(^ADGDS(DFN)) N X,Y,DGDSN0,DGDSN2 S (X,Y)=0
F S X=$O(^ADGDS(DFN,"DS","AA",X)) Q:'X S Y=X
Q:'Y S X=$O(^ADGDS(DFN,"DS","AA",Y,0)) Q:'X
Q:'$D(^ADGDS(DFN,"DS",X,0)) S DS=X,DGDSN0=^(0),DGDSN2=$G(^(2))
W !!,"DAY SURGERY date: ",$$DSDT
W:DGDSN2 ?38,"Released: ",$$DSRL," LOS: ",$$DSLS
I $P(DGDSN2,U,3)="Y" W ?38,"**CANCELLED**"
I $P(DGDSN2,U,4)="Y" W ?38,"**NO-SHOW**"
W !?9,"Service: ",$$DSSV,?38,"Provider: ",$$DSPR Q
;
SV ; -- scheduled visit
Q:'$D(^ADGAUTH(DFN,1,0)) N X,Y,DGSVN0 S (X,Y)=0
F S X=$O(^ADGAUTH(DFN,1,X)) Q:'X D
. S DGSVN0=^ADGAUTH(DFN,1,X,0)
. Q:$P(DGSVN0,U,5)=""!("IQD"'[$P(DGSVN0,U,5))
. D @("SV"_$P(DGSVN0,U,5))
Q
;
SVI ; -- scheduled admit
N X S X=+DGSVN0
W !!?10,"Scheduled Admit for ",$E(X,4,5),"/",$E(X,6,7),"/",$E(X,2,3)
S X=$P(DGSVN0,U,7) W:X ?43,"Ward: ",$E($P($G(^DIC(42,+X,0)),U),1,3)
S X=$P(DGSVN0,U,3) W:X ?55,"Service: ",$P($G(^DIC(45.7,+X,0)),U,3) Q
;
SVQ ; -- scheduled quarters
N X S X=+DGSVN0 W !!?10,"Scheduled for Quarters on "
W $E(X,4,5),"/",$E(X,6,7),"/",$E(X,2,3) S X=$P(DGSVN0,U,2)
W ?50,"Provider: " W:X $E($P($G(^DIC(45.7,+X,0)),U,3),1,20) Q
;
SVD ; -- scheduled day surgery
N X S X=+DGSVN0 W !!?10,"Scheduled for Day Surgery on "
W $E(X,4,5),"/",$E(X,6,7),"/",$E(X,2,3)
S X=$P(DGSVN0,U,3) W:X " Service: ",$P(^DIC(45.7,X,0),U,3) Q
;
FA ; -- scheduled future appointments
;9/17/02 WAR Chgd to accomodate v5.3 DaySurgery
;D FA^DGRPD Q
D FA^ADGRPD Q
;
IN ; -- insurance (from health summary)
;N APCHSPAT,APCHSCKP,APCHSNPG,APCHSCVD,APCHSBRK,APCHSQ
S APCHSPAT=DFN,APCHSCKP="",APCHSNPG=0,APCHSBRK=""
S APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_$E(Y,2,3)"
W !! D ^APCHS5 Q
;
PG ; -- page
N X,Y K DIR S DIR(0)="E" D ^DIR K DIR,X Q
;
DOB() ; -- date of birth
N Y S Y=$P(DGDPTN0,U,3) X ^DD("DD") Q Y
;
ELIG() ; -- eligibility status
N Y,C S Y=$P(DGPATN11,U,12) S C=$P(^DD(9000001,1112,0),U,2)
D Y^DIQ Q $E(Y,1,13)
;
ST() ; -- state
Q $P($G(^DIC(5,+$P(DGDPTN11,U,5),0)),U,2)
;
DSDT() ; -- day surgery date/time
N Y S Y=+DGDSN0 X ^DD("DD") Q Y
;
DSSV() ; -- day surgery treating specialty
Q $E($P($G(^DIC(45.7,+$P(DGDSN0,U,5),0)),U),1,20)
;
DSPR() ; -- day surgery provider
Q $E($P($G(^VA(200,+$P(DGDSN0,U,6),0)),U),1,20)
;
DSRL() ; -- day surgery release date/time
N Y S Y=+DGDSN2 X ^DD("DD") Q Y
;
DSLS() ; -- day surgery length of stay
Q:'DS "" D Q X_" hrs"
. K ^UTILITY("DIQ1",$J) S DR(9009012.01)=8,DA(9009012.01)=DS
. S DIC=9009012,DA=DFN,DR=1 D EN^DIQ1
. S X=$G(^UTILITY("DIQ1",$J,9009012.01,DS,8))
. K ^UTILITY("DIQ1",$J),DIC,DA,DR
;
PCP() ; -- primary care provider
I $P(^DD(9000001,.14,0),U,2)["200" Q $E($P($G(^VA(200,+$P(^AUPNPAT(DFN,0),U,14),0)),U),1,20)
Q $E($P($G(^DIC(16,+$P(^AUPNPAT(DFN,0),U,14),0)),U),1,20)
ADGPI ; IHS/ADC/PDW/ENM - PATIENT INQUIRY ; [ 09/17/2002 4:19 PM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
SP ; -- select patient
+1 NEW DFN,DIC,Y,X
SET DIC="^DPT("
SET DIC(0)="AEQMZ"
+2 DO ^DIC
KILL DIC
IF Y'>0
QUIT
SET DFN=+Y
DO EN
GOTO SP
+3 ;
EN ;EP; entry point - input DFN
+1 IF '$DATA(DFN)
QUIT
DO DM
DO CS
DO DS
DO SV
DO FA
DO KVA^VADPT
DO IN
DO PG
QUIT
+2 ;
DM ; -- demographic data
+1 NEW DGDPTN0,DGDPTN11,DGDPTN13,DGPATN0,DGPATN11
+2 SET DGDPTN0=^DPT(DFN,0)
SET DGDPTN11=$GET(^(.11))
SET DGDPTN13=$GET(^(.13))
+3 SET DGPATN0=$GET(^AUPNPAT(DFN,0))
SET DGPATN11=$GET(^(11))
+4 WRITE !!?13,"***Confidential Patient Data Covered by Privacy Act***"
+5 WRITE !!,$PIECE(DGDPTN0,U),?32,"HRCN: ",$$HRCN^ADGF,?54,"DOB: ",$$DOB
+6 WRITE !,$PIECE(DGDPTN11,U),?31,"PHONE: ",$PIECE(DGDPTN13,U),?53,"PROV: ",$$PCP
+7 WRITE !,$PIECE(DGDPTN11,U,4)," ",$$ST," ",$PIECE(DGDPTN11,U,6)
+8 WRITE ?32,"ELIG: ",$$ELIG,?54,"SSN: ",$PIECE(DGDPTN0,U,9)
QUIT
+9 ;
CS ; -- current status
+1 ;D INP^DGRPD Q
+2 ;9/17/02 WAR Modified to allow for v5.3 DaySurgery
DO INP^ADGRPD
QUIT
+3 ;
DS ; -- last day surgery
+1 SET X="SRZPEP"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET DGCK=$$LASTDS^SRZPEP
+2 IF $GET(DGCK)
QUIT
+3 IF '$DATA(^ADGDS(DFN))
QUIT
NEW X,Y,DGDSN0,DGDSN2
SET (X,Y)=0
+4 FOR
SET X=$ORDER(^ADGDS(DFN,"DS","AA",X))
IF 'X
QUIT
SET Y=X
+5 IF 'Y
QUIT
SET X=$ORDER(^ADGDS(DFN,"DS","AA",Y,0))
IF 'X
QUIT
+6 IF '$DATA(^ADGDS(DFN,"DS",X,0))
QUIT
SET DS=X
SET DGDSN0=^(0)
SET DGDSN2=$GET(^(2))
+7 WRITE !!,"DAY SURGERY date: ",$$DSDT
+8 IF DGDSN2
WRITE ?38,"Released: ",$$DSRL," LOS: ",$$DSLS
+9 IF $PIECE(DGDSN2,U,3)="Y"
WRITE ?38,"**CANCELLED**"
+10 IF $PIECE(DGDSN2,U,4)="Y"
WRITE ?38,"**NO-SHOW**"
+11 WRITE !?9,"Service: ",$$DSSV,?38,"Provider: ",$$DSPR
QUIT
+12 ;
SV ; -- scheduled visit
+1 IF '$DATA(^ADGAUTH(DFN,1,0))
QUIT
NEW X,Y,DGSVN0
SET (X,Y)=0
+2 FOR
SET X=$ORDER(^ADGAUTH(DFN,1,X))
IF 'X
QUIT
Begin DoDot:1
+3 SET DGSVN0=^ADGAUTH(DFN,1,X,0)
+4 IF $PIECE(DGSVN0,U,5)=""!("IQD"'[$PIECE(DGSVN0,U,5))
QUIT
+5 DO @("SV"_$PIECE(DGSVN0,U,5))
End DoDot:1
+6 QUIT
+7 ;
SVI ; -- scheduled admit
+1 NEW X
SET X=+DGSVN0
+2 WRITE !!?10,"Scheduled Admit for ",$EXTRACT(X,4,5),"/",$EXTRACT(X,6,7),"/",$EXTRACT(X,2,3)
+3 SET X=$PIECE(DGSVN0,U,7)
IF X
WRITE ?43,"Ward: ",$EXTRACT($PIECE($GET(^DIC(42,+X,0)),U),1,3)
+4 SET X=$PIECE(DGSVN0,U,3)
IF X
WRITE ?55,"Service: ",$PIECE($GET(^DIC(45.7,+X,0)),U,3)
QUIT
+5 ;
SVQ ; -- scheduled quarters
+1 NEW X
SET X=+DGSVN0
WRITE !!?10,"Scheduled for Quarters on "
+2 WRITE $EXTRACT(X,4,5),"/",$EXTRACT(X,6,7),"/",$EXTRACT(X,2,3)
SET X=$PIECE(DGSVN0,U,2)
+3 WRITE ?50,"Provider: "
IF X
WRITE $EXTRACT($PIECE($GET(^DIC(45.7,+X,0)),U,3),1,20)
QUIT
+4 ;
SVD ; -- scheduled day surgery
+1 NEW X
SET X=+DGSVN0
WRITE !!?10,"Scheduled for Day Surgery on "
+2 WRITE $EXTRACT(X,4,5),"/",$EXTRACT(X,6,7),"/",$EXTRACT(X,2,3)
+3 SET X=$PIECE(DGSVN0,U,3)
IF X
WRITE " Service: ",$PIECE(^DIC(45.7,X,0),U,3)
QUIT
+4 ;
FA ; -- scheduled future appointments
+1 ;9/17/02 WAR Chgd to accomodate v5.3 DaySurgery
+2 ;D FA^DGRPD Q
+3 DO FA^ADGRPD
QUIT
+4 ;
IN ; -- insurance (from health summary)
+1 ;N APCHSPAT,APCHSCKP,APCHSNPG,APCHSCVD,APCHSBRK,APCHSQ
+2 SET APCHSPAT=DFN
SET APCHSCKP=""
SET APCHSNPG=0
SET APCHSBRK=""
+3 SET APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_$E(Y,2,3)"
+4 WRITE !!
DO ^APCHS5
QUIT
+5 ;
PG ; -- page
+1 NEW X,Y
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR,X
QUIT
+2 ;
DOB() ; -- date of birth
+1 NEW Y
SET Y=$PIECE(DGDPTN0,U,3)
XECUTE ^DD("DD")
QUIT Y
+2 ;
ELIG() ; -- eligibility status
+1 NEW Y,C
SET Y=$PIECE(DGPATN11,U,12)
SET C=$PIECE(^DD(9000001,1112,0),U,2)
+2 DO Y^DIQ
QUIT $EXTRACT(Y,1,13)
+3 ;
ST() ; -- state
+1 QUIT $PIECE($GET(^DIC(5,+$PIECE(DGDPTN11,U,5),0)),U,2)
+2 ;
DSDT() ; -- day surgery date/time
+1 NEW Y
SET Y=+DGDSN0
XECUTE ^DD("DD")
QUIT Y
+2 ;
DSSV() ; -- day surgery treating specialty
+1 QUIT $EXTRACT($PIECE($GET(^DIC(45.7,+$PIECE(DGDSN0,U,5),0)),U),1,20)
+2 ;
DSPR() ; -- day surgery provider
+1 QUIT $EXTRACT($PIECE($GET(^VA(200,+$PIECE(DGDSN0,U,6),0)),U),1,20)
+2 ;
DSRL() ; -- day surgery release date/time
+1 NEW Y
SET Y=+DGDSN2
XECUTE ^DD("DD")
QUIT Y
+2 ;
DSLS() ; -- day surgery length of stay
+1 IF 'DS
QUIT ""
Begin DoDot:1
+2 KILL ^UTILITY("DIQ1",$JOB)
SET DR(9009012.01)=8
SET DA(9009012.01)=DS
+3 SET DIC=9009012
SET DA=DFN
SET DR=1
DO EN^DIQ1
+4 SET X=$GET(^UTILITY("DIQ1",$JOB,9009012.01,DS,8))
+5 KILL ^UTILITY("DIQ1",$JOB),DIC,DA,DR
End DoDot:1
QUIT X_" hrs"
+6 ;
PCP() ; -- primary care provider
+1 IF $PIECE(^DD(9000001,.14,0),U,2)["200"
QUIT $EXTRACT($PIECE($GET(^VA(200,+$PIECE(^AUPNPAT(DFN,0),U,14),0)),U),1,20)
+2 QUIT $EXTRACT($PIECE($GET(^DIC(16,+$PIECE(^AUPNPAT(DFN,0),U,14),0)),U),1,20)
