- APCLAUD1 ; IHS/CMI/LAB - more audit report ;
- ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- ;PRINT AUDIT SEARCH PCC VISITS
- START ;
- S APCL80D="--------------------------------------------------------------------------------" ;80 DASHES
- S Y=APCLBD X ^DD("DD") S APCLBDY=Y S Y=APCLED X ^DD("DD") S APCLEDY=Y S Y=DT X ^DD("DD") S APCLDTP=Y
- SITE S APCLSITE=DUZ(2)
- S (APCLPG,APCLCNT)=0
- I $D(^XTMP("APCLAUD",APCLJOB,APCLBT,"PROV","ALL")) S APCLALLP=""
- I $D(^XTMP("APCLAUD",APCLJOB,APCLBT,"ICDDFN","ALL")) S APCLALLI=""
- I $D(^XTMP("APCLAUD",APCLJOB,APCLBT,"RAND","ALL")) S APCLALLR=""
- I $D(^XTMP("APCLAUD",APCLJOB,APCLBT,"PROV","NOSORT")) S (APCLNOSP,APCLALLP)=""
- S APCLLIM=$O(^XTMP("APCLAUD",APCLJOB,APCLBT,"RAND",""))
- S APCLS=APCLBD-.0001
- F I=0:0 S APCLS=$O(^AUPNVSIT("B",APCLS)) Q:APCLS=""!(APCLS>(APCLED+.2359)) D C1
- S APCLET=$H G DONE
- C1 S APCLVDFN=0 F J=0:0 S APCLVDFN=$O(^AUPNVSIT("B",APCLS,APCLVDFN)) Q:APCLVDFN="" D C2
- Q
- C2 Q:'$D(^AUPNVSIT(APCLVDFN,0))
- S APCLVN0=^AUPNVSIT(APCLVDFN,0)
- S APCLPNUM=$P(APCLVN0,U,5)
- Q:$$DEMO^APCLUTL(APCLPNUM,$G(APCLDEMO))
- I $D(APCLSC),APCLSC'=$P(APCLVN0,U,7) Q
- Q:$P(APCLVN0,"^",11)
- I $D(APCLTYPE),$P(APCLVN0,U,3)'=APCLTYPE Q
- I $D(APCLCLN),APCLCLN'=$P(APCLVN0,U,8) Q
- I $D(APCLLOC),APCLLOC'=$P(APCLVN0,U,6) Q
- I $D(APCLSEX),APCLSEX'=$P(^DPT(APCLPNUM,0),U,2) Q
- G:'$D(APCLLAG) PRVCK
- S APCLPDYS=$S($D(^DPT($P(APCLVN0,"^",5),0)):$P(^(0),"^",3),1:"") Q:APCLPDYS="" S X1=$P(APCLS,"."),X2=APCLPDYS D ^%DTC S APCLPDYS=X
- Q:APCLPDYS<APCLLAG Q:APCLPDYS>APCLHAG
- PRVCK S APCLPDFN="" F K=0:0 S APCLPDFN=$O(^AUPNVPRV("AD",APCLVDFN,APCLPDFN)) Q:APCLPDFN="" D P1
- Q
- P1 Q:'$D(^AUPNVPRV(APCLPDFN,0))
- S APCLPN0=^AUPNVPRV(APCLPDFN,0),APCLPNO=+APCLPN0,APCLPPR=$P(APCLPN0,"^",4),APCLPNO1=APCLPNO
- Q:APCLPPR'="P"
- G:$D(APCLALLP) ICDCK
- Q:'$D(^XTMP("APCLAUD",APCLJOB,APCLBT,"PROV",APCLPNO))
- ICDCK S APCLIDFN="" F S APCLIDFN=$O(^AUPNVPOV("AD",APCLVDFN,APCLIDFN)) Q:APCLIDFN="" D I1
- Q
- I1 Q:'$D(^AUPNVPOV(APCLIDFN,0))
- S APCLINO=+^AUPNVPOV(APCLIDFN,0)
- I $D(APCLALLI) S APCLIRNG=0 G I11
- Q:'$D(^XTMP("APCLAUD",APCLJOB,APCLBT,"ICDDFN",APCLINO))
- S APCLIRNG=$O(^XTMP("APCLAUD",APCLJOB,APCLBT,"ICDDFN",APCLINO,""))
- I11 S:$D(APCLNOSP) APCLPNO="ALL"
- S ^XTMP("APCLAUD2",APCLJOB,APCLBT,APCLPNO,APCLIRNG,APCLINO,APCLVDFN)=APCLPNO1_U_APCLIDFN
- Q:$D(APCLALLR)
- S ^XTMP("APCLAUD2",APCLJOB,APCLBT,APCLPNO,APCLIRNG,0)=$S($D(^XTMP("APCLAUD2",APCLJOB,APCLBT,APCLPNO,APCLIRNG,0)):^(0)+1,1:1)
- Q
- DONE Q
- APCLAUD1 ; IHS/CMI/LAB - more audit report ;
- +1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- +2 ;PRINT AUDIT SEARCH PCC VISITS
- START ;
- +1 ;80 DASHES
- SET APCL80D="--------------------------------------------------------------------------------"
- +2 SET Y=APCLBD
- XECUTE ^DD("DD")
- SET APCLBDY=Y
- SET Y=APCLED
- XECUTE ^DD("DD")
- SET APCLEDY=Y
- SET Y=DT
- XECUTE ^DD("DD")
- SET APCLDTP=Y
- SITE SET APCLSITE=DUZ(2)
- +1 SET (APCLPG,APCLCNT)=0
- +2 IF $DATA(^XTMP("APCLAUD",APCLJOB,APCLBT,"PROV","ALL"))
- SET APCLALLP=""
- +3 IF $DATA(^XTMP("APCLAUD",APCLJOB,APCLBT,"ICDDFN","ALL"))
- SET APCLALLI=""
- +4 IF $DATA(^XTMP("APCLAUD",APCLJOB,APCLBT,"RAND","ALL"))
- SET APCLALLR=""
- +5 IF $DATA(^XTMP("APCLAUD",APCLJOB,APCLBT,"PROV","NOSORT"))
- SET (APCLNOSP,APCLALLP)=""
- +6 SET APCLLIM=$ORDER(^XTMP("APCLAUD",APCLJOB,APCLBT,"RAND",""))
- +7 SET APCLS=APCLBD-.0001
- +8 FOR I=0:0
- SET APCLS=$ORDER(^AUPNVSIT("B",APCLS))
- IF APCLS=""!(APCLS>(APCLED+.2359))
- QUIT
- DO C1
- +9 SET APCLET=$HOROLOG
- GOTO DONE
- C1 SET APCLVDFN=0
- FOR J=0:0
- SET APCLVDFN=$ORDER(^AUPNVSIT("B",APCLS,APCLVDFN))
- IF APCLVDFN=""
- QUIT
- DO C2
- +1 QUIT
- C2 IF '$DATA(^AUPNVSIT(APCLVDFN,0))
- QUIT
- +1 SET APCLVN0=^AUPNVSIT(APCLVDFN,0)
- +2 SET APCLPNUM=$PIECE(APCLVN0,U,5)
- +3 IF $$DEMO^APCLUTL(APCLPNUM,$GET(APCLDEMO))
- QUIT
- +4 IF $DATA(APCLSC)
- IF APCLSC'=$PIECE(APCLVN0,U,7)
- QUIT
- +5 IF $PIECE(APCLVN0,"^",11)
- QUIT
- +6 IF $DATA(APCLTYPE)
- IF $PIECE(APCLVN0,U,3)'=APCLTYPE
- QUIT
- +7 IF $DATA(APCLCLN)
- IF APCLCLN'=$PIECE(APCLVN0,U,8)
- QUIT
- +8 IF $DATA(APCLLOC)
- IF APCLLOC'=$PIECE(APCLVN0,U,6)
- QUIT
- +9 IF $DATA(APCLSEX)
- IF APCLSEX'=$PIECE(^DPT(APCLPNUM,0),U,2)
- QUIT
- +10 IF '$DATA(APCLLAG)
- GOTO PRVCK
- +11 SET APCLPDYS=$SELECT($DATA(^DPT($PIECE(APCLVN0,"^",5),0)):$PIECE(^(0),"^",3),1:"")
- IF APCLPDYS=""
- QUIT
- SET X1=$PIECE(APCLS,".")
- SET X2=APCLPDYS
- DO ^%DTC
- SET APCLPDYS=X
- +12 IF APCLPDYS<APCLLAG
- QUIT
- IF APCLPDYS>APCLHAG
- QUIT
- PRVCK SET APCLPDFN=""
- FOR K=0:0
- SET APCLPDFN=$ORDER(^AUPNVPRV("AD",APCLVDFN,APCLPDFN))
- IF APCLPDFN=""
- QUIT
- DO P1
- +1 QUIT
- P1 IF '$DATA(^AUPNVPRV(APCLPDFN,0))
- QUIT
- +1 SET APCLPN0=^AUPNVPRV(APCLPDFN,0)
- SET APCLPNO=+APCLPN0
- SET APCLPPR=$PIECE(APCLPN0,"^",4)
- SET APCLPNO1=APCLPNO
- +2 IF APCLPPR'="P"
- QUIT
- +3 IF $DATA(APCLALLP)
- GOTO ICDCK
- +4 IF '$DATA(^XTMP("APCLAUD",APCLJOB,APCLBT,"PROV",APCLPNO))
- QUIT
- ICDCK SET APCLIDFN=""
- FOR
- SET APCLIDFN=$ORDER(^AUPNVPOV("AD",APCLVDFN,APCLIDFN))
- IF APCLIDFN=""
- QUIT
- DO I1
- +1 QUIT
- I1 IF '$DATA(^AUPNVPOV(APCLIDFN,0))
- QUIT
- +1 SET APCLINO=+^AUPNVPOV(APCLIDFN,0)
- +2 IF $DATA(APCLALLI)
- SET APCLIRNG=0
- GOTO I11
- +3 IF '$DATA(^XTMP("APCLAUD",APCLJOB,APCLBT,"ICDDFN",APCLINO))
- QUIT
- +4 SET APCLIRNG=$ORDER(^XTMP("APCLAUD",APCLJOB,APCLBT,"ICDDFN",APCLINO,""))
- I11 IF $DATA(APCLNOSP)
- SET APCLPNO="ALL"
- +1 SET ^XTMP("APCLAUD2",APCLJOB,APCLBT,APCLPNO,APCLIRNG,APCLINO,APCLVDFN)=APCLPNO1_U_APCLIDFN
- +2 IF $DATA(APCLALLR)
- QUIT
- +3 SET ^XTMP("APCLAUD2",APCLJOB,APCLBT,APCLPNO,APCLIRNG,0)=$SELECT($DATA(^XTMP("APCLAUD2",APCLJOB,APCLBT,APCLPNO,APCLIRNG,0)):^(0)+1,1:1)
- +4 QUIT
- DONE QUIT
