- 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 Jan 18, 2025@03:47:21 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