Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGOINS1

DGOINS1.m

Go to the documentation of this file.
  1. DGOINS1 ;ALB/MAC - OUTPUT FOR PATIENTS ADMITTED WITH UNKNOWN INSURANCE ; SEP 12 1988@1:00
  1. ;;5.3;Registration;**162**;Aug 13, 1993
  1. 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
  1. 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
  1. I DGL="C" G PP
  1. 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
  1. PP I '$D(^UTILITY($J,"DGM")) S DGD=1 W !,"=====>NO PATIENTS FOUND" G QUIT
  1. 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
  1. G QUIT:DGU D TT G QUIT:DGU
  1. I DGS(3)>0!(DGS(4)>0) D MC
  1. 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
  1. 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
  1. QUIT D CLOSE^DGUTQ Q
  1. LP F DFN=0:0 S DFN=$O(^UTILITY($J,"DGM",DGDV,DGP,DGD,DFN)) Q:DFN=""!(DGU) D PRINT,CT
  1. Q
  1. UTIL I $D(^DPT(DFN,.3)) Q:(DGSC=2)&($P(^(.3),"^",1)="Y")
  1. Q:'$D(^DGPM(DGCA,0)) S DGNO=^(0) S:DGL="C" DGD=$P(DGNO,"^",1) D INP^VADPT S X=+VAIN(4) K VAIN
  1. Q:'$D(^DIC(42,+X,0)) S Y=$P(^DIC(42,X,0),"^",11) G:Y="" UT Q:'VAUTD&('$D(VAUTD(Y)))
  1. UT I $D(^DPT(DFN,.31)) S X=$P(^(.31),"^",11) Q:X="Y"!(X="N")
  1. S DGP=$P(^DPT(DFN,0),"^",1) S DGDV=$S(Y="":"ZNOT SPECIFIED",1:$P(^DG(40.8,Y,0),"^",1))
  1. S ^UTILITY($J,"DGM",DGDV,DGP,DGD,DFN)=""
  1. Q
  1. CT I '$D(^DPT(DFN,.31)) S DGS(3)=DGS(3)+1,DGS(1)=DGS(1)+1 Q
  1. S X=$P(^DPT(DFN,.31),"^",11) I X="" S DGS(3)=DGS(3)+1,DGS(1)=DGS(1)+1 Q
  1. S DGS(4)=DGS(4)+1,DGS(2)=DGS(2)+1 Q
  1. 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
  1. 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
  1. S DGC=0 Q
  1. PRINT I $Y+4>IOSL D:IOST?1"C-".E RT Q:DGU D HEAD
  1. S X=+$P(^DPT(DFN,0),"^",3) I X S X=$$FMTE^XLFDT(X,"5DF"),X=$TR(X," ","0"),X=$TR(X,"/","-")
  1. 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)
  1. 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)
  1. Q
  1. W !!?3,"PATIENT",?30,"PT ID",?43,"DOB",?52,"VET",?58,"SC",?63,"ADMISSION DATE",!,DGCL
  1. Q
  1. HEAD2 W " ACTIVE PATIENTS",!?23,"WITH UNKNOWN/UNANSWERED INSURANCE",!
  1. I DGL="C" S DGT="FOR "_$P(DGDT,"@",1)
  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")
  1. S DGY=40-($L(DGT)/2) W ?DGY,DGT Q
  1. RT F X=$Y:1:(IOSL-2) W !
  1. R !?22,"Enter <RET> to continue or ^ to QUIT",X:DTIME S:X["^"!('$T) DGU=1 Q:DGU=1
  1. Q
  1. MC Q:DGU W @IOF,!?60,DGDT,!?19,"MEDICAL CENTER TOTALS FOR" D HEAD2 W !,DGCL Q
  1. NT W "# - Denotes prompt left blank by user" Q