DGOINS1 ;ALB/MAC - OUTPUT FOR PATIENTS ADMITTED WITH UNKNOWN INSURANCE ; SEP 12 1988@1:00
;;5.3;Registration;**162**;Aug 13, 1993
START D NOW^%DTC S Y=$E(%,1,12),DGDT=$$FMTE^XLFDT(Y,1),(DGN,DGC,DGU,DGV)="",$P(DGCL,"*",81)="",L=1 F X=1:1:4 S DGS(X)=0
I DGL="C" S DGW=0 F X1=0:0 S DGW=$O(^DPT("CN",DGW)) Q:DGW="" F DFN=0:0 S DFN=$O(^DPT("CN",DGW,DFN)) Q:DFN="" S DGCA=^(DFN) I $D(^DGPM(+DGCA,0)),$P(^DGPM(+DGCA,0),"^",2)=1 D UTIL
I DGL="C" G PP
SR F DGD=DGBEG1:0 S DGD=$O(^DGPM("AMV1",DGD)) Q:(DGD="")!(DGD\1>DGEND1) F DFN=0:0 S DFN=$O(^DGPM("AMV1",DGD,DFN)) Q:DFN="" F DGCA=0:0 S DGCA=$O(^DGPM("AMV1",DGD,DFN,DGCA)) Q:DGCA="" D UTIL
PP I '$D(^UTILITY($J,"DGM")) S DGD=1 W !,"=====>NO PATIENTS FOUND" G QUIT
S DGDV=0 F K=0:0 S DGDV=$O(^UTILITY($J,"DGM",DGDV)) Q:DGDV=""!(DGU) D TT Q:DGU D HEAD S DGP=0 F DGJ=0:0 S DGP=$O(^UTILITY($J,"DGM",DGDV,DGP)) Q:DGP=""!(DGU) S DGV=DGDV F DGD=0:0 S DGD=$O(^UTILITY($J,"DGM",DGDV,DGP,DGD)) Q:DGD=""!(DGU) D LP
G QUIT:DGU D TT G QUIT:DGU
I DGS(3)>0!(DGS(4)>0) D MC
F K=0:0 S K=$O(DGL(K)) Q:K=""!(DGU) S DGL=DGL(K) W !!,"DIVISION: ",$P(DGL,"^",1),!!?10,"Number of unknown",?34,": ",$J($P(DGL,"^",3),5),!?9,"#Number of unanswered",?34,": ",$J($P(DGL,"^",2),5) I IOST?1"C-".E&($Y+7>IOSL) D RT,MC
G QUIT:DGU I DGS(3)>0!(DGS(4)>0) W !!?5,"MEDICAL CENTER:",!?10,"Total number of unknown",?34,": ",$J(DGS(4),5),!?9,"#Total number unanswered",?34,": ",$J(DGS(3),5),!?36,"-----",!?29,"TOTAL",?34,": ",$J(DGS(4)+DGS(3),5) W !! D NT
QUIT D CLOSE^DGUTQ Q
LP F DFN=0:0 S DFN=$O(^UTILITY($J,"DGM",DGDV,DGP,DGD,DFN)) Q:DFN=""!(DGU) D PRINT,CT
Q
UTIL I $D(^DPT(DFN,.3)) Q:(DGSC=2)&($P(^(.3),"^",1)="Y")
Q:'$D(^DGPM(DGCA,0)) S DGNO=^(0) S:DGL="C" DGD=$P(DGNO,"^",1) D INP^VADPT S X=+VAIN(4) K VAIN
Q:'$D(^DIC(42,+X,0)) S Y=$P(^DIC(42,X,0),"^",11) G:Y="" UT Q:'VAUTD&('$D(VAUTD(Y)))
UT I $D(^DPT(DFN,.31)) S X=$P(^(.31),"^",11) Q:X="Y"!(X="N")
S DGP=$P(^DPT(DFN,0),"^",1) S DGDV=$S(Y="":"ZNOT SPECIFIED",1:$P(^DG(40.8,Y,0),"^",1))
S ^UTILITY($J,"DGM",DGDV,DGP,DGD,DFN)=""
Q
CT I '$D(^DPT(DFN,.31)) S DGS(3)=DGS(3)+1,DGS(1)=DGS(1)+1 Q
S X=$P(^DPT(DFN,.31),"^",11) I X="" S DGS(3)=DGS(3)+1,DGS(1)=DGS(1)+1 Q
S DGS(4)=DGS(4)+1,DGS(2)=DGS(2)+1 Q
TT S DGV=$S(DGV="ZNOT SPECIFIED":"NOT SPECIFIED",1:DGV) I $Y+6>IOSL&(DGS(1)>0)!($Y+6>IOSL&(DGS(2)>0)) D:IOST?1"C-".E RT Q:DGU S DGC=DGC+1 W @IOF,!?3,"DIVISION: ",DGV,?50,DGDT," PAGE ",DGC,!!?22,"DIVISION SUMMARY FOR" D HEAD2 W !!,DGCL
I DGS(1)>0!DGS(2)>0 W !!!?3,"DIVISION: ",DGV,!?5,"Number of Unknown: ",$J(DGS(2),5),!?4,"#Number Unanswered: ",$J(DGS(1),5),?40 D NT S DGL(L)="",DGL(L)=DGV_"^"_DGS(1)_"^"_DGS(2),L=L+1,(DGS(1),DGS(2))=0 D:IOST?1"C-".E RT S DGC=0 Q
S DGC=0 Q
PRINT I $Y+4>IOSL D:IOST?1"C-".E RT Q:DGU D HEAD
S X=+$P(^DPT(DFN,0),"^",3) I X S X=$$FMTE^XLFDT(X,"5DF"),X=$TR(X," ","0"),X=$TR(X,"/","-")
D PID^VADPT6 W !,$S('$D(^DPT(DFN,.31)):"#",$P(^DPT(DFN,.31),"^",11)="":"#",1:" ")_DGP,?27 W:VA("PID")]"" VA("PID") W ?40,X,?52 W:$D(^DPT(DFN,"VET")) $J(^("VET")_$S(^("VET")="Y":"ES",^("VET")="N":"O",1:""),3)
W ?57 S X=$P($S($D(^DPT(DFN,.3)):^(.3),1:""),"^",1),X=$P(X,"^",1) W:X]"" $J(X_$S(X="Y":"ES",1:"O"),3) W ?62 S Y=DGD X ^DD("DD") W $P(Y,"@",1)_"@"_$E($P(Y,"@",2),1,5)
Q
HEAD S DGC=DGC+1 W @IOF,!?3,"DIVISION: ",$S(DGDV="ZNOT SPECIFIED":"NOT SPECIFIED",1:DGDV),?50,DGDT," PAGE ",DGC,!?31 D HEAD2
W !!?3,"PATIENT",?30,"PT ID",?43,"DOB",?52,"VET",?58,"SC",?63,"ADMISSION DATE",!,DGCL
Q
HEAD2 W " ACTIVE PATIENTS",!?23,"WITH UNKNOWN/UNANSWERED INSURANCE",!
I DGL="C" S DGT="FOR "_$P(DGDT,"@",1)
I DGL="D" S DGT=$S(DGBEG=DGEND:"FOR ",1:"FROM "),DGT=DGT_$$FMTE^XLFDT(DGBEG,"1D") I DGEND'=DGBEG S DGT=DGT_" TO "_$$FMTE^XLFDT(DGEND,"1D")
S DGY=40-($L(DGT)/2) W ?DGY,DGT Q
RT F X=$Y:1:(IOSL-2) W !
R !?22,"Enter <RET> to continue or ^ to QUIT",X:DTIME S:X["^"!('$T) DGU=1 Q:DGU=1
Q
MC Q:DGU W @IOF,!?60,DGDT,!?19,"MEDICAL CENTER TOTALS FOR" D HEAD2 W !,DGCL Q
NT W "# - Denotes prompt left blank by user" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGOINS1 3968 printed Apr 09, 2024@21:54:55 Page 2
DGOINS1 ;ALB/MAC - OUTPUT FOR PATIENTS ADMITTED WITH UNKNOWN INSURANCE ; SEP 12 1988@1:00
+1 ;;5.3;Registration;**162**;Aug 13, 1993
START DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
SET DGDT=$$FMTE^XLFDT(Y,1)
SET (DGN,DGC,DGU,DGV)=""
SET $PIECE(DGCL,"*",81)=""
SET L=1
FOR X=1:1:4
SET DGS(X)=0
+1 IF DGL="C"
SET DGW=0
FOR X1=0:0
SET DGW=$ORDER(^DPT("CN",DGW))
if DGW=""
QUIT
FOR DFN=0:0
SET DFN=$ORDER(^DPT("CN",DGW,DFN))
if DFN=""
QUIT
SET DGCA=^(DFN)
IF $DATA(^DGPM(+DGCA,0))
IF $PIECE(^DGPM(+DGCA,0),"^",2)=1
DO UTIL
+2 IF DGL="C"
GOTO PP
SR FOR DGD=DGBEG1:0
SET DGD=$ORDER(^DGPM("AMV1",DGD))
if (DGD="")!(DGD\1>DGEND1)
QUIT
FOR DFN=0:0
SET DFN=$ORDER(^DGPM("AMV1",DGD,DFN))
if DFN=""
QUIT
FOR DGCA=0:0
SET DGCA=$ORDER(^DGPM("AMV1",DGD,DFN,DGCA))
if DGCA=""
QUIT
DO UTIL
PP IF '$DATA(^UTILITY($JOB,"DGM"))
SET DGD=1
WRITE !,"=====>NO PATIENTS FOUND"
GOTO QUIT
+1 SET DGDV=0
FOR K=0:0
SET DGDV=$ORDER(^UTILITY($JOB,"DGM",DGDV))
if DGDV=""!(DGU)
QUIT
DO TT
if DGU
QUIT
DO HEAD
SET DGP=0
FOR DGJ=0:0
SET DGP=$ORDER(^UTILITY($JOB,"DGM",DGDV,DGP))
if DGP=""!(DGU)
QUIT
SET DGV=DGDV
FOR DGD=0:0
SET DGD=$ORDER(^UTILITY($JOB,"DGM",DGDV,DGP,DGD))
if DGD=""!(DGU)
QUIT
DO LP
+2 if DGU
GOTO QUIT
DO TT
if DGU
GOTO QUIT
+3 IF DGS(3)>0!(DGS(4)>0)
DO MC
+4 FOR K=0:0
SET K=$ORDER(DGL(K))
if K=""!(DGU)
QUIT
SET DGL=DGL(K)
WRITE !!,"DIVISION: ",$PIECE(DGL,"^",1),!!?10,"Number of unknown",?34,": ",$JUSTIFY($PIECE(DGL,"^",3),5),!?9,"#Number of unanswered",?34,": ",$JUSTIFY($PIECE(DGL,"^",2),5)
IF IOST?1"C-".E&($Y+7>IOSL)
DO RT
DO MC
+5 if DGU
GOTO QUIT
IF DGS(3)>0!(DGS(4)>0)
WRITE !!?5,"MEDICAL CENTER:",!?10,"Total number of unknown",?34,": ",$JUSTIFY(DGS(4),5),!?9,"#Total number unanswered",?34,": ",$JUSTIFY(DGS(3),5),!?36,"-----",!?29,"TOTAL",?34,": ",$JUSTIFY(DGS(4)+DGS(3),5)
WRITE !!
DO NT
QUIT DO CLOSE^DGUTQ
QUIT
LP FOR DFN=0:0
SET DFN=$ORDER(^UTILITY($JOB,"DGM",DGDV,DGP,DGD,DFN))
if DFN=""!(DGU)
QUIT
DO PRINT
DO CT
+1 QUIT
UTIL IF $DATA(^DPT(DFN,.3))
if (DGSC=2)&($PIECE(^(.3),"^",1)="Y")
QUIT
+1 if '$DATA(^DGPM(DGCA,0))
QUIT
SET DGNO=^(0)
if DGL="C"
SET DGD=$PIECE(DGNO,"^",1)
DO INP^VADPT
SET X=+VAIN(4)
KILL VAIN
+2 if '$DATA(^DIC(42,+X,0))
QUIT
SET Y=$PIECE(^DIC(42,X,0),"^",11)
if Y=""
GOTO UT
if 'VAUTD&('$DATA(VAUTD(Y)))
QUIT
UT IF $DATA(^DPT(DFN,.31))
SET X=$PIECE(^(.31),"^",11)
if X="Y"!(X="N")
QUIT
+1 SET DGP=$PIECE(^DPT(DFN,0),"^",1)
SET DGDV=$SELECT(Y="":"ZNOT SPECIFIED",1:$PIECE(^DG(40.8,Y,0),"^",1))
+2 SET ^UTILITY($JOB,"DGM",DGDV,DGP,DGD,DFN)=""
+3 QUIT
CT IF '$DATA(^DPT(DFN,.31))
SET DGS(3)=DGS(3)+1
SET DGS(1)=DGS(1)+1
QUIT
+1 SET X=$PIECE(^DPT(DFN,.31),"^",11)
IF X=""
SET DGS(3)=DGS(3)+1
SET DGS(1)=DGS(1)+1
QUIT
+2 SET DGS(4)=DGS(4)+1
SET DGS(2)=DGS(2)+1
QUIT
TT SET DGV=$SELECT(DGV="ZNOT SPECIFIED":"NOT SPECIFIED",1:DGV)
IF $Y+6>IOSL&(DGS(1)>0)!($Y+6>IOSL&(DGS(2)>0))
if IOST?1"C-".E
DO RT
if DGU
QUIT
SET DGC=DGC+1
WRITE @IOF,!?3,"DIVISION: ",DGV,?50,DGDT," PAGE ",DGC,!!?22,"DIVISION SUMMARY FOR"
DO HEAD2
WRITE !!,DGCL
+1 IF DGS(1)>0!DGS(2)>0
WRITE !!!?3,"DIVISION: ",DGV,!?5,"Number of Unknown: ",$JUSTIFY(DGS(2),5),!?4,"#Number Unanswered: ",$JUSTIFY(DGS(1),5),?40
DO NT
SET DGL(L)=""
SET DGL(L)=DGV_"^"_DGS(1)_"^"_DGS(2)
SET L=L+1
SET (DGS(1),DGS(2))=0
if IOST?1"C-".E
DO RT
SET DGC=0
QUIT
+2 SET DGC=0
QUIT
PRINT IF $Y+4>IOSL
if IOST?1"C-".E
DO RT
if DGU
QUIT
DO HEAD
+1 SET X=+$PIECE(^DPT(DFN,0),"^",3)
IF X
SET X=$$FMTE^XLFDT(X,"5DF")
SET X=$TRANSLATE(X," ","0")
SET X=$TRANSLATE(X,"/","-")
+2 DO PID^VADPT6
WRITE !,$SELECT('$DATA(^DPT(DFN,.31)):"#",$PIECE(^DPT(DFN,.31),"^",11)="":"#",1:" ")_DGP,?27
if VA("PID")]""
WRITE VA("PID")
WRITE ?40,X,?52
if $DATA(^DPT(DFN,"VET"))
WRITE $JUSTIFY(^("VET")_$SELECT(^("VET")="Y":"ES",^("VET")="N":"O",1:""),3)
+3 WRITE ?57
SET X=$PIECE($SELECT($DATA(^DPT(DFN,.3)):^(.3),1:""),"^",1)
SET X=$PIECE(X,"^",1)
if X]""
WRITE $JUSTIFY(X_$SELECT(X="Y":"ES",1:"O"),3)
WRITE ?62
SET Y=DGD
XECUTE ^DD("DD")
WRITE $PIECE(Y,"@",1)_"@"_$EXTRACT($PIECE(Y,"@",2),1,5)
+4 QUIT
HEAD SET DGC=DGC+1
WRITE @IOF,!?3,"DIVISION: ",$SELECT(DGDV="ZNOT SPECIFIED":"NOT SPECIFIED",1:DGDV),?50,DGDT," PAGE ",DGC,!?31
DO HEAD2
+1 WRITE !!?3,"PATIENT",?30,"PT ID",?43,"DOB",?52,"VET",?58,"SC",?63,"ADMISSION DATE",!,DGCL
+2 QUIT
HEAD2 WRITE " ACTIVE PATIENTS",!?23,"WITH UNKNOWN/UNANSWERED INSURANCE",!
+1 IF DGL="C"
SET DGT="FOR "_$PIECE(DGDT,"@",1)
+2 IF DGL="D"
SET DGT=$SELECT(DGBEG=DGEND:"FOR ",1:"FROM ")
SET DGT=DGT_$$FMTE^XLFDT(DGBEG,"1D")
IF DGEND'=DGBEG
SET DGT=DGT_" TO "_$$FMTE^XLFDT(DGEND,"1D")
+3 SET DGY=40-($LENGTH(DGT)/2)
WRITE ?DGY,DGT
QUIT
RT FOR X=$Y:1:(IOSL-2)
WRITE !
+1 READ !?22,"Enter <RET> to continue or ^ to QUIT",X:DTIME
if X["^"!('$TEST)
SET DGU=1
if DGU=1
QUIT
+2 QUIT
MC if DGU
QUIT
WRITE @IOF,!?60,DGDT,!?19,"MEDICAL CENTER TOTALS FOR"
DO HEAD2
WRITE !,DGCL
QUIT
NT WRITE "# - Denotes prompt left blank by user"
QUIT
