APCDR00 ; IHS/CMI/LAB - REVIEW VISIT RECORD ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;IHS/CMI/TUCSON - patch 1 for file 200 conversion sites
START ;
D PPPV
D GETACC
D VISIT^APCDR001
EOJ ;clean up and exit
K APCD1,APCD2,APCDE,APCDY,APCDL,APCDX,APCDCLN,APCDLDFN,APCDAP,APCDLL
K X,Y,%DT
Q
ERR ;
D ERR^APCDRV
Q
PPPV ;EP;check for primary prov and pov
Q:"EI"[$P(APCDVREC,U,7)
I $G(APCDRTYP)="R",'$D(^AUPNVRAD("AD",APCDVSIT)) Q
I $G(APCDRTYP)="L",'$D(^AUPNVLAB("AD",APCDVSIT)) Q
I $G(APCDRTYP)="I",'$D(^AUPNVIMM("AD",APCDVSIT)) Q
I $G(APCDRTYP)="P",'$D(^AUPNVMED("AD",APCDVSIT)) Q
I '$D(^AUPNVPOV("AD",APCDVSIT)) S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E102" D ERR
D:$P(APCDVREC,U,7)="H" CHECKPV
S (APCD1,APCD2,APCDPPRV)=0 F S APCD2=$O(^AUPNVPRV("AD",APCDVSIT,APCD2)) Q:APCD2="" I $P(^AUPNVPRV(APCD2,0),U,4)="P" S APCD1=APCD1+1,APCDPPRV=$P(^(0),U),APCDAP=APCD2
I APCD1=0 S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E101" D ERR,EOJ Q
I APCD1>1 S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E103" D ERR,EOJ Q
PRIPRV ;
D PRI200
Q
CHECKPV ;
S (APCD1,APCD2)=0 F S APCD2=$O(^AUPNVPOV("AD",APCDVSIT,APCD2)) Q:APCD2="" I $P(^AUPNVPOV(APCD2,0),U,12)="P" S APCD1=APCD1+1
I APCD1=0 S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E300" D ERR I 1
E I APCD1>1 S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E301" D ERR
Q
;
;
GETACC ;get accept command if there is one and save variable
K APCDACC
;$O THRU V POV'S FOR ACCEPT
S APCD2=0 F S APCD2=$O(^AUPNVPOV("AD",APCDVSIT,APCD2)) Q:APCD2="" I $P(^AUPNVPOV(APCD2,0),U,14)]"" S APCDACC=""
Q:$D(APCDACC)
;$O THRU V PROCEDURES FOR ACCEPT
S APCD2=0 F S APCD2=$O(^AUPNVPRC("AD",APCDVSIT,APCD2)) Q:APCD2="" I $P(^AUPNVPRC(APCD2,0),U,9)]"" S APCDACC=""
Q:$D(APCDACC)
Q:$P(APCDVREC,U,7)'="H"
Q:'$D(^AUPNVINP("AD",APCDVSIT))
S APCD1=$O(^AUPNVINP("AD",APCDVSIT,""))
I $P(^AUPNVINP(APCD1,0),U,14)]"" S APCDACC=""
Q
PRI200 ;CMI/TUCSON/LAB - for file 200 conversion PATCH 1
S (APCDPDIS,APCDX,APCDPAFF,APCDPCOD,APCDY)=""
I $G(^VA(200,APCDPPRV,9999999))="" S APCDE("FILE")=9000010.06,APCDE("ENTRY")=APCDAP,APCDE="E002" D ERR,EOJ Q
S APCDPAFF=$$PROVAFFL^XBFUNC1(APCDPPRV,"I") I APCDPAFF="" S APCDE("FILE")=9000010.06,APCDE("ENTRY")=APCDAP,APCDE="E028" D ERR,EOJ Q
S APCDPDIS=$$PROVCLSC^XBFUNC1(APCDPPRV) I APCDPDIS="" S APCDE("FILE")=9000010.06,APCDE("ENTRY")=APCDAP,APCDE="E027" D ERR,EOJ Q
S APCDPCOD=$$PROVCODE^XBFUNC1(APCDPPRV) I APCDPCOD="" S APCDE("FILE")=9000010.06,APCDE("ENTRY")=APCDAP,APCDE="E002" D ERR,EOJ Q
D EOJ
Q
APCDR00 ; IHS/CMI/LAB - REVIEW VISIT RECORD ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;IHS/CMI/TUCSON - patch 1 for file 200 conversion sites
START ;
+1 DO PPPV
+2 DO GETACC
+3 DO VISIT^APCDR001
EOJ ;clean up and exit
+1 KILL APCD1,APCD2,APCDE,APCDY,APCDL,APCDX,APCDCLN,APCDLDFN,APCDAP,APCDLL
+2 KILL X,Y,%DT
+3 QUIT
ERR ;
+1 DO ERR^APCDRV
+2 QUIT
PPPV ;EP;check for primary prov and pov
+1 IF "EI"[$PIECE(APCDVREC,U,7)
QUIT
+2 IF $GET(APCDRTYP)="R"
IF '$DATA(^AUPNVRAD("AD",APCDVSIT))
QUIT
+3 IF $GET(APCDRTYP)="L"
IF '$DATA(^AUPNVLAB("AD",APCDVSIT))
QUIT
+4 IF $GET(APCDRTYP)="I"
IF '$DATA(^AUPNVIMM("AD",APCDVSIT))
QUIT
+5 IF $GET(APCDRTYP)="P"
IF '$DATA(^AUPNVMED("AD",APCDVSIT))
QUIT
+6 IF '$DATA(^AUPNVPOV("AD",APCDVSIT))
SET APCDE("FILE")=9000010
SET APCDE("ENTRY")=APCDVSIT
SET APCDE="E102"
DO ERR
+7 IF $PIECE(APCDVREC,U,7)="H"
DO CHECKPV
+8 SET (APCD1,APCD2,APCDPPRV)=0
FOR
SET APCD2=$ORDER(^AUPNVPRV("AD",APCDVSIT,APCD2))
IF APCD2=""
QUIT
IF $PIECE(^AUPNVPRV(APCD2,0),U,4)="P"
SET APCD1=APCD1+1
SET APCDPPRV=$PIECE(^(0),U)
SET APCDAP=APCD2
+9 IF APCD1=0
SET APCDE("FILE")=9000010
SET APCDE("ENTRY")=APCDVSIT
SET APCDE="E101"
DO ERR
DO EOJ
QUIT
+10 IF APCD1>1
SET APCDE("FILE")=9000010
SET APCDE("ENTRY")=APCDVSIT
SET APCDE="E103"
DO ERR
DO EOJ
QUIT
PRIPRV ;
+1 DO PRI200
+2 QUIT
CHECKPV ;
+1 SET (APCD1,APCD2)=0
FOR
SET APCD2=$ORDER(^AUPNVPOV("AD",APCDVSIT,APCD2))
IF APCD2=""
QUIT
IF $PIECE(^AUPNVPOV(APCD2,0),U,12)="P"
SET APCD1=APCD1+1
+2 IF APCD1=0
SET APCDE("FILE")=9000010
SET APCDE("ENTRY")=APCDVSIT
SET APCDE="E300"
DO ERR
IF 1
+3 IF '$TEST
IF APCD1>1
SET APCDE("FILE")=9000010
SET APCDE("ENTRY")=APCDVSIT
SET APCDE="E301"
DO ERR
+4 QUIT
+5 ;
+6 ;
GETACC ;get accept command if there is one and save variable
+1 KILL APCDACC
+2 ;$O THRU V POV'S FOR ACCEPT
+3 SET APCD2=0
FOR
SET APCD2=$ORDER(^AUPNVPOV("AD",APCDVSIT,APCD2))
IF APCD2=""
QUIT
IF $PIECE(^AUPNVPOV(APCD2,0),U,14)]""
SET APCDACC=""
+4 IF $DATA(APCDACC)
QUIT
+5 ;$O THRU V PROCEDURES FOR ACCEPT
+6 SET APCD2=0
FOR
SET APCD2=$ORDER(^AUPNVPRC("AD",APCDVSIT,APCD2))
IF APCD2=""
QUIT
IF $PIECE(^AUPNVPRC(APCD2,0),U,9)]""
SET APCDACC=""
+7 IF $DATA(APCDACC)
QUIT
+8 IF $PIECE(APCDVREC,U,7)'="H"
QUIT
+9 IF '$DATA(^AUPNVINP("AD",APCDVSIT))
QUIT
+10 SET APCD1=$ORDER(^AUPNVINP("AD",APCDVSIT,""))
+11 IF $PIECE(^AUPNVINP(APCD1,0),U,14)]""
SET APCDACC=""
+12 QUIT
PRI200 ;CMI/TUCSON/LAB - for file 200 conversion PATCH 1
+1 SET (APCDPDIS,APCDX,APCDPAFF,APCDPCOD,APCDY)=""
+2 IF $GET(^VA(200,APCDPPRV,9999999))=""
SET APCDE("FILE")=9000010.06
SET APCDE("ENTRY")=APCDAP
SET APCDE="E002"
DO ERR
DO EOJ
QUIT
+3 SET APCDPAFF=$$PROVAFFL^XBFUNC1(APCDPPRV,"I")
IF APCDPAFF=""
SET APCDE("FILE")=9000010.06
SET APCDE("ENTRY")=APCDAP
SET APCDE="E028"
DO ERR
DO EOJ
QUIT
+4 SET APCDPDIS=$$PROVCLSC^XBFUNC1(APCDPPRV)
IF APCDPDIS=""
SET APCDE("FILE")=9000010.06
SET APCDE("ENTRY")=APCDAP
SET APCDE="E027"
DO ERR
DO EOJ
QUIT
+5 SET APCDPCOD=$$PROVCODE^XBFUNC1(APCDPPRV)
IF APCDPCOD=""
SET APCDE("FILE")=9000010.06
SET APCDE("ENTRY")=APCDAP
SET APCDE="E002"
DO ERR
DO EOJ
QUIT
+6 DO EOJ
+7 QUIT
