ADGRPD ; IHS/ADC/PDW/ENM - PATIENT INQUIRY (NEW) 5/21/91 15:17 ; [ 09/17/2002 4:12 PM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;;MAS VERSION 5.0;
;IHS/ANMC/RAM,LJF;
; -- added ;EP to labels FA and INP
;IHS/HQW/KML 2/12/97 replace $N with $O w/o changing functionality
;IHS/HQW/WAR 9/17/02 renamed rtn from version 5.0 to accomodate v5.3
;
SEL K DFN,DGRPOUT W ! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S DFN=+Y D EN G SEL
;
EN ;call to display patient inquiry - input DFN
D CHECK^DGPMV ;convert on the fly - remove after v5
K DGRPOUT,DGHOW S DGABBRV=$S($D(^DG(43,1,0)):+$P(^(0),"^",38),1:0),DGRPU="UNSPECIFIED" D DEM^VADPT,HDR F I=0,.11,.13,.121,.31,.32,.36,.361 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU S DGTMPAD=0 I $P(DGRP(.121),"^",9)="Y" S DGTMPAD=$S('$P(DGRP(.121),"^",8):1,$P(DGRP(.121),"^",8)'<DT:1,1:0) I DGTMPAD S DGAD=.121,DGA1=1,DGA2=2 D A^DGRPU
W "Address: ",$S($D(DGA(1)):DGA(1),1:"NONE ON FILE"),?40,"Temporary: ",$S($D(DGA(2)):DGA(2),1:"NO TEMPORARY ADDRESS")
S I=2 F I1=0:0 S I=$O(DGA(I)) Q:'I W:(I#2)!($X>50) !?9 W:'(I#2) ?51 W DGA(I)
S DGCC=+$P(DGRP(.11),U,7),DGST=+$P(DGRP(.11),U,5),DGCC=$S($D(^DIC(5,DGST,1,DGCC,0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) W !?1,"County: ",DGCC
S X="NOT APPLICABLE" I DGTMPAD S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD") S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD") S X=X_$S(Y]"":Y,1:DGRPU)
W ?42,"From/To: ",X,!?2,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$S('DGTMPAD:X,$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU) K DGTMPAD
W !?1,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU) I 'DGABBRV W !?4,"POS: ",$S($D(^DIC(21,+$P(DGRP(.32),"^",3),0)):$P(^(0),"^",1),1:DGRPU),?42,"Claim #: ",$S($P(DGRP(.31),"^",3)]"":$P(DGRP(.31),"^",3),1:"")
I 'DGABBRV W !?2,"Relig: ",$S($D(^DIC(13,+$P(DGRP(0),"^",8),0)):$P(^(0),"^",1),1:DGRPU),?46,"Sex: ",$P(VADM(5),"^",2)
S X1=DGRP(.36),X=$P(DGRP(.361),"^",1) W !!,"Primary Eligibility: ",$S($D(^DIC(8,+X1,0)):$P(^(0),"^",1)_" ("_$S(X="V":"VERIFIED",X="P":"PENDING VERIFICATION",X="R":"PENDING REVERIFICATION",1:"NOT VERIFIED")_")",1:DGRPU)
W !,"Other Eligibilities: " F I=0:0 S I=$O(^DIC(8,I)) Q:'I I $D(^DIC(8,I,0)),I'=+X1 S X=$P(^(0),"^",1)_", " I $D(^DPT("AEL",DFN,I)) W:$X+$L(X)>79 !?21 W X
;D ^DGMT1 I 'DGABBRV F I=$Y:1:20 W ! ;IHS
I 'DGABBRV F I=$Y:1:20 W !
I 'DGABBRV S DIR(0)="E" D ^DIR K DIR S:'Y DGRPOUT=1 G:'Y Q D HDR
S VAIP("L")="" D INP,SA
Q D KVA^VADPT K %DT,DGA,DGABBRV,I,LDM,X,I1,DGAD,DGA1,DGA2,DGMTLL,DGRP,DGRPU,DGS,DGXFR0,X1,VA,Y,DGCC,DGST,D0,D1,DIC,POP,SDCT Q
HDR I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP
W @IOF,!,$P(VADM(1),"^",1),?40,$P(VADM(2),"^",2),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",78)="" W !,X,! Q
INP ;EP; called by ^ADGPI, ^ADGPM1 ;IHS added
;9/17/02 WAR Chgd call to reflect v5.3 rtn name change
;S VAHOW=2,VAIP("D")="L" D IN5^DGPMV10
S VAHOW=2,VAIP("D")="L" D IN5^ADGPMV10
S DGPMT=0 K ^UTILITY("VAIP",$J)
;9/17/02 WAR Chgd call to reflect v5.3 rtn name change
;D CS^DGPMV10 K DGPMT,DGPMIFN K:'$D(DGSWITCH) DGPMVI,DGPMDCD Q
D CS^ADGPMV10 K DGPMT,DGPMIFN K:'$D(DGSWITCH) DGPMVI,DGPMDCD Q
SA F I=0:0 S I=$O(^DGS(41.1,"B",DFN,I)) G CL:'I S X=^DGS(41.1,I,0) I $P(X,"^",2)>(DT-1),$P(X,"^",13)']"",'$P(X,"^",17) S L=$P(X,"^",2) W !?18,"Scheduled Admit" D SAA
Q
SAA W $S($D(^DIC(42,+$P(X,"^",8),0)):" on ward "_$P(^(0),"^",1),$D(^DIC(45.7,+$P(X,"^",9),0)):" for treating specialty "_$P(^(0),"^",1),1:"")," on ",$E(L,4,5),"/",$E(L,6,7),"/",$E(L,2,3) Q
CL G FA:$O(^DPT(DFN,"DE",0))="" S SDCT=0 F I=0:0 S I=$O(^DPT(DFN,"DE",I)) Q:'I I $D(^(I,0)),$P(^(0),"^",2)'="I",$O(^(0)) S SDCT=SDCT+1 W:SDCT=1 !!,"Currently enrolled in " W:$X>50 !?22 W $S($D(^SC(+^(0),0)):$P(^(0),"^",1)_", ",1:"")
;
FA ;EP; called by ^ADGPI; IHS added
S CT=0 W !!,"Future Appointments: " I $O(^DPT(DFN,"S",DT))="" W "NONE" G RMK
W ?22,"Date",?32,"Time",?39,"Clinic",!?22 F I=22:1:75 W "="
F FA=DT:0 S FA=$O(^DPT(DFN,"S",FA)) G RMK:'FA S L=^(FA,0),C=+L I $P(L,"^",2)'["C" D COV W !?22,$E(FA,4,5),"/",$E(FA,6,7),"/",$E(FA,2,3),$J(+$E(FA_"00",9,10)_":"_$E(FA_"0000",11,12),6),?39,$P($S($D(^SC(C,0)):^(0),1:""),"^")," ",COV Q:CT>5
I $O(^DPT(DFN,"S",FA))>0 W !,"See Scheduling options for additional appointments."
RMK ;W !!,"Remarks: ",$P(^DPT(DFN,0),"^",10) ;IHS
W:$P(^DPT(DFN,0),"^",10)'="" !!,"Remarks: ",$P(^(0),"^",10) ;IHS
K ADM,TRN,DIS,SSN,FA,C,COV,NOW,CT,DGD,DGD1,I ;Y killed after dghinqky
Q
COV S COV=$S($P(L,"^",7)=7:" (Collateral) ",1:""),COV=COV_$S($P(L,"^",2)["N":" * NO-SHOW *",1:""),CT=CT+1 Q
Q
;
OREN S XQORQUIT=1 Q:'$D(ORVP) S DFN=+ORVP D EN R !!,"Press RETURN to CONTINUE: ",X:DTIME
Q
ADGRPD ; IHS/ADC/PDW/ENM - PATIENT INQUIRY (NEW) 5/21/91 15:17 ; [ 09/17/2002 4:12 PM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;;MAS VERSION 5.0;
+3 ;IHS/ANMC/RAM,LJF;
+4 ; -- added ;EP to labels FA and INP
+5 ;IHS/HQW/KML 2/12/97 replace $N with $O w/o changing functionality
+6 ;IHS/HQW/WAR 9/17/02 renamed rtn from version 5.0 to accomodate v5.3
+7 ;
SEL KILL DFN,DGRPOUT
WRITE !
SET DIC="^DPT("
SET DIC(0)="AEQMZ"
DO ^DIC
IF Y'>0
GOTO Q
SET DFN=+Y
DO EN
GOTO SEL
+1 ;
EN ;call to display patient inquiry - input DFN
+1 ;convert on the fly - remove after v5
DO CHECK^DGPMV
+2 KILL DGRPOUT,DGHOW
SET DGABBRV=$SELECT($DATA(^DG(43,1,0)):+$PIECE(^(0),"^",38),1:0)
SET DGRPU="UNSPECIFIED"
DO DEM^VADPT
DO HDR
FOR I=0,.11,.13,.121,.31,.32,.36,.361
SET DGRP(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")
+3 SET DGAD=.11
SET (DGA1,DGA2)=1
DO A^DGRPU
SET DGTMPAD=0
IF $PIECE(DGRP(.121),"^",9)="Y"
SET DGTMPAD=$SELECT('$PIECE(DGRP(.121),"^",8):1,$PIECE(DGRP(.121),"^",8)'<DT:1,1:0)
IF DGTMPAD
SET DGAD=.121
SET DGA1=1
SET DGA2=2
DO A^DGRPU
+4 WRITE "Address: ",$SELECT($DATA(DGA(1)):DGA(1),1:"NONE ON FILE"),?40,"Temporary: ",$SELECT($DATA(DGA(2)):DGA(2),1:"NO TEMPORARY ADDRESS")
+5 SET I=2
FOR I1=0:0
SET I=$ORDER(DGA(I))
IF 'I
QUIT
IF (I#2)!($X>50)
WRITE !?9
IF '(I#2)
WRITE ?51
WRITE DGA(I)
+6 SET DGCC=+$PIECE(DGRP(.11),U,7)
SET DGST=+$PIECE(DGRP(.11),U,5)
SET DGCC=$SELECT($DATA(^DIC(5,DGST,1,DGCC,0)):$EXTRACT($PIECE(^(0),U,1),1,20)_$SELECT($PIECE(^(0),U,3)]"":" ("_$PIECE(^(0),U,3)_")",1:""),1:DGRPU)
WRITE !?1,"County: ",DGCC
+7 SET X="NOT APPLICABLE"
IF DGTMPAD
SET Y=$PIECE(DGRP(.121),U,7)
IF Y]""
XECUTE ^DD("DD")
SET X=$SELECT(Y]"":Y,1:DGRPU)_"-"
SET Y=$PIECE(DGRP(.121),U,8)
IF Y]""
XECUTE ^DD("DD")
SET X=X_$SELECT(Y]"":Y,1:DGRPU)
+8 WRITE ?42,"From/To: ",X,!?2,"Phone: ",$SELECT($PIECE(DGRP(.13),U,1)]"":$PIECE(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$SELECT('DGTMPAD:X,$PIECE(DGRP(.121),U,10)]"":$PIECE(DGRP(.121),U,10),1:DGRPU)
KILL DGTMPAD
+9 WRITE !?1,"Office: ",$SELECT($PIECE(DGRP(.13),U,2)]"":$PIECE(DGRP(.13),U,2),1:DGRPU)
IF 'DGABBRV
WRITE !?4,"POS: ",$SELECT($DATA(^DIC(21,+$PIECE(DGRP(.32),"^",3),0)):$PIECE(^(0),"^",1),1:DGRPU),?42,"Claim #: ",$SELECT($PIECE(DGRP(.31),"^",3)]"":$PIECE(DGRP(.31),"^",3),1:"")
+10 IF 'DGABBRV
WRITE !?2,"Relig: ",$SELECT($DATA(^DIC(13,+$PIECE(DGRP(0),"^",8),0)):$PIECE(^(0),"^",1),1:DGRPU),?46,"Sex: ",$PIECE(VADM(5),"^",2)
+11 SET X1=DGRP(.36)
SET X=$PIECE(DGRP(.361),"^",1)
WRITE !!,"Primary Eligibility: ",$SELECT($DATA(^DIC(8,+X1,0)):$PIECE(^(0),"^",1)_" ("_$SELECT(X="V":"VERIFIED",X="P":"PENDING VERIFICATION",X="R":"PENDING REVERIFICATION",1:"NOT VERIFIED")_")",1:DGRPU)
+12 WRITE !,"Other Eligibilities: "
FOR I=0:0
SET I=$ORDER(^DIC(8,I))
IF 'I
QUIT
IF $DATA(^DIC(8,I,0))
IF I'=+X1
SET X=$PIECE(^(0),"^",1)_", "
IF $DATA(^DPT("AEL",DFN,I))
IF $X+$LENGTH(X)>79
WRITE !?21
WRITE X
+13 ;D ^DGMT1 I 'DGABBRV F I=$Y:1:20 W ! ;IHS
+14 IF 'DGABBRV
FOR I=$Y:1:20
WRITE !
+15 IF 'DGABBRV
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET DGRPOUT=1
IF 'Y
GOTO Q
DO HDR
+16 SET VAIP("L")=""
DO INP
DO SA
Q DO KVA^VADPT
KILL %DT,DGA,DGABBRV,I,LDM,X,I1,DGAD,DGA1,DGA2,DGMTLL,DGRP,DGRPU,DGS,DGXFR0,X1,VA,Y,DGCC,DGST,D0,D1,DIC,POP,SDCT
QUIT
HDR IF '$DATA(IOF)
SET IOP="HOME"
DO ^%ZIS
KILL IOP
+1 WRITE @IOF,!,$PIECE(VADM(1),"^",1),?40,$PIECE(VADM(2),"^",2),?65,$PIECE(VADM(3),"^",2)
SET X=""
SET $PIECE(X,"=",78)=""
WRITE !,X,!
QUIT
INP ;EP; called by ^ADGPI, ^ADGPM1 ;IHS added
+1 ;9/17/02 WAR Chgd call to reflect v5.3 rtn name change
+2 ;S VAHOW=2,VAIP("D")="L" D IN5^DGPMV10
+3 SET VAHOW=2
SET VAIP("D")="L"
DO IN5^ADGPMV10
+4 SET DGPMT=0
KILL ^UTILITY("VAIP",$JOB)
+5 ;9/17/02 WAR Chgd call to reflect v5.3 rtn name change
+6 ;D CS^DGPMV10 K DGPMT,DGPMIFN K:'$D(DGSWITCH) DGPMVI,DGPMDCD Q
+7 DO CS^ADGPMV10
KILL DGPMT,DGPMIFN
IF '$DATA(DGSWITCH)
KILL DGPMVI,DGPMDCD
QUIT
SA FOR I=0:0
SET I=$ORDER(^DGS(41.1,"B",DFN,I))
IF 'I
GOTO CL
SET X=^DGS(41.1,I,0)
IF $PIECE(X,"^",2)>(DT-1)
IF $PIECE(X,"^",13)']""
IF '$PIECE(X,"^",17)
SET L=$PIECE(X,"^",2)
WRITE !?18,"Scheduled Admit"
DO SAA
+1 QUIT
SAA WRITE $SELECT($DATA(^DIC(42,+$PIECE(X,"^",8),0)):" on ward "_$PIECE(^(0),"^",1),$DATA(^DIC(45.7,+$PIECE(X,"^",9),0)):" for treating specialty "_$PIECE(^(0),"^",1),1:"")," on ",$EXTRACT(L,4,5),"/",$EXTRACT(L,6,7),"/",$EXTRACT(L,2,3)
QUIT
CL IF $ORDER(^DPT(DFN,"DE",0))=""
GOTO FA
SET SDCT=0
FOR I=0:0
SET I=$ORDER(^DPT(DFN,"DE",I))
IF 'I
QUIT
IF $DATA(^(I,0))
IF $PIECE(^(0),"^",2)'="I"
IF $ORDER(^(0))
SET SDCT=SDCT+1
IF SDCT=1
WRITE !!,"Currently enrolled in "
IF $X>50
WRITE !?22
WRITE $SELECT($DATA(^SC(+^(0),0)):$PIECE(^(0),"^",1)_", ",1:"")
+1 ;
FA ;EP; called by ^ADGPI; IHS added
+1 SET CT=0
WRITE !!,"Future Appointments: "
IF $ORDER(^DPT(DFN,"S",DT))=""
WRITE "NONE"
GOTO RMK
+2 WRITE ?22,"Date",?32,"Time",?39,"Clinic",!?22
FOR I=22:1:75
WRITE "="
+3 FOR FA=DT:0
SET FA=$ORDER(^DPT(DFN,"S",FA))
IF 'FA
GOTO RMK
SET L=^(FA,0)
SET C=+L
IF $PIECE(L,"^",2)'["C"
DO COV
WRITE !?22,$EXTRACT(FA,4,5),"/",$EXTRACT(FA,6,7),"/",$EXTRACT(FA,2,3),$JUSTIFY(+$EXTRACT(FA_"00",9,10)_":"_$EXTRACT(FA_"0000",11,12),6),?39,$PIECE($SELECT($DATA(^SC(C,0)):^(0),1:""),"^")," ",COV
IF CT>5
QUIT
+4 IF $ORDER(^DPT(DFN,"S",FA))>0
WRITE !,"See Scheduling options for additional appointments."
RMK ;W !!,"Remarks: ",$P(^DPT(DFN,0),"^",10) ;IHS
+1 ;IHS
IF $PIECE(^DPT(DFN,0),"^",10)'=""
WRITE !!,"Remarks: ",$PIECE(^(0),"^",10)
+2 ;Y killed after dghinqky
KILL ADM,TRN,DIS,SSN,FA,C,COV,NOW,CT,DGD,DGD1,I
+3 QUIT
COV SET COV=$SELECT($PIECE(L,"^",7)=7:" (Collateral) ",1:"")
SET COV=COV_$SELECT($PIECE(L,"^",2)["N":" * NO-SHOW *",1:"")
SET CT=CT+1
QUIT
+1 QUIT
+2 ;
OREN SET XQORQUIT=1
IF '$DATA(ORVP)
QUIT
SET DFN=+ORVP
DO EN
READ !!,"Press RETURN to CONTINUE: ",X:DTIME
+1 QUIT
