- 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
