- 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
