RMPR145P ;VM/RB - FIX PROBLEM PCE ENCOUNTERS FROM FILE #660 ITEMS ;03/27/08
;;3.0;Prosthetics;**145**;13/27/08;Build 6
;;
Q
FIXPCE ;1. Post install to correct 'action required' PCE Encounters created
; from Prosthetic items via nightly PCE interface and edit/delete
; issues/orders.
;
BUILD K ^XTMP("RMPR145P") D NOW^%DTC S RMSTART=%
S ^XTMP("RMPR145P","START COMPILE")=RMSTART
S ^XTMP("RMPR145P","END COMPILE")="RUNNING"
S ^XTMP("RMPR145P",0)=$$FMADD^XLFDT(RMSTART,90)_"^"_RMSTART
0 ;FIND 660 RECORDS WITH PCE LINKS
S IEN=0,U="^",XX=0,TOT=0
1 S IEN=$O(^RMPR(660,IEN)) G EXIT:IEN=""!(IEN]"@")
S R=$G(^RMPR(660,IEN,0)),DFN=$P(R,U,2),R10=$G(^RMPR(660,IEN,10))
;I $E($P(R,U),1,3)<306 G 1
G:DFN="" 1 S PNAME=$P(^DPT(DFN,0),U,1)
I R=""!(R10="") G 1
S VISIEN=$P(R10,U,12) I VISIEN="" G 1
S RV=$G(^AUPNVSIT(VISIEN,0)) I RV="" G 1
S RV8=$G(^AUPNVSIT(VISIEN,800))
2 ;check for required contaminants in associated encounter
S PCEIEN=$O(^SCE("AVSIT",VISIEN,0)) I PCEIEN="" G 1
S PCE0=$G(^SCE(PCEIEN,0)) I PCE0="" G 1
I $P(PCE0,U,12)'=14 G 1
EVAL ;beginning of evaluation criteria for 'action required'
S SDOE=PCEIEN
S SDOE0=$$GETOE^SDOE(SDOE),SDIV=$P(SDOE0,U,11)
D DEM^VADPT M SDDPT=VADM
K SDX D CLASK^SDCO2(PCEIEN,.SDX)
I '$D(SDX) G 1
S SDI=0,ERR=0,SDXX="" F S SDI=$O(SDX(SDI)) Q:'SDI I $P(SDX(SDI),U,2)="" S SDX="" D I SDX'="" S ERR=1,^XTMP("RMPR145P",660,IEN,99,SDI)=SDX(SDI)_U_SDX,SDXX=SDXX_U_SDI
. I '$D(^SD(409.41,SDI,0)) S SDX="Classification required" S:'$D(TOT(SDI)) TOT(SDI)=0 S TOT(SDI)=TOT(SDI)+1 Q ;W !,SDX Q
. S SDX=$P($G(^SD(409.41,SDI,0)),U,1)_" classification required" S:'$D(TOT(SDI)) TOT(SDI)=0 S TOT(SDI)=TOT(SDI)+1 ;W !,SDX
I ERR=1 S TOT=TOT+1 D
. S ^XTMP("RMPR145P",660,IEN,10)=R
. S ^XTMP("RMPR145P",660,IEN,10)=R10
. S ^XTMP("RMPR145P",660,IEN,11)=RV
. S ^XTMP("RMPR145P",660,IEN,12)=RV8
. S ^XTMP("RMPR145P",660,IEN,13)=PCE0
. ;W !!,IEN,?15,PNAME,!,R,!,R10,!,VISIEN,!,RV,!,RV8,!,PCEIEN,!,PCE0,!,SDXX
. F I=1:1:7 I $P(RV8,U,I)="" S XX=80000+I,DA=VISIEN,DR=XX_"////^S X=0",DIE="^AUPNVSIT(" D ^DIE
. S DA=PCEIEN,DR=".12////^S X=2",DIE="^SCE(" D ^DIE
G 1
EXIT ;
;S II=0 W !
;F S II=$O(TOT(II)) Q:II="" D
;. S ENM=$P($G(^SD(409.41,II,0)),U)
;. W !,ENM," classification required",?50,TOT(II)
;W !!,"TOTAL 'ACTION REQUIRED' ENCOUNTERS CORRECTED: ",TOT
D NOW^%DTC S RMEND=%
M ^XTMP("RMPR145P","ERRS")=TOT
S ^XTMP("RMPR145P","END COMPILE")=RMEND
K RMEND,RMSTART,IEN,XX,TOT,R,R10,DFN,PCEIEN,VISIEN,PNAME,RV,RV8,PCE0,SDOE,SDOE0,SDIV,VADM,SDDPT,SDX,SDI
K ERR,SDXX,TOT,I,DA,DR,DIE,II,ENM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR145P 2610 printed Apr 09, 2024@21:39:36 Page 2
RMPR145P ;VM/RB - FIX PROBLEM PCE ENCOUNTERS FROM FILE #660 ITEMS ;03/27/08
+1 ;;3.0;Prosthetics;**145**;13/27/08;Build 6
+2 ;;
+3 QUIT
FIXPCE ;1. Post install to correct 'action required' PCE Encounters created
+1 ; from Prosthetic items via nightly PCE interface and edit/delete
+2 ; issues/orders.
+3 ;
BUILD KILL ^XTMP("RMPR145P")
DO NOW^%DTC
SET RMSTART=%
+1 SET ^XTMP("RMPR145P","START COMPILE")=RMSTART
+2 SET ^XTMP("RMPR145P","END COMPILE")="RUNNING"
+3 SET ^XTMP("RMPR145P",0)=$$FMADD^XLFDT(RMSTART,90)_"^"_RMSTART
0 ;FIND 660 RECORDS WITH PCE LINKS
+1 SET IEN=0
SET U="^"
SET XX=0
SET TOT=0
1 SET IEN=$ORDER(^RMPR(660,IEN))
if IEN=""!(IEN]"@")
GOTO EXIT
+1 SET R=$GET(^RMPR(660,IEN,0))
SET DFN=$PIECE(R,U,2)
SET R10=$GET(^RMPR(660,IEN,10))
+2 ;I $E($P(R,U),1,3)<306 G 1
+3 if DFN=""
GOTO 1
SET PNAME=$PIECE(^DPT(DFN,0),U,1)
+4 IF R=""!(R10="")
GOTO 1
+5 SET VISIEN=$PIECE(R10,U,12)
IF VISIEN=""
GOTO 1
+6 SET RV=$GET(^AUPNVSIT(VISIEN,0))
IF RV=""
GOTO 1
+7 SET RV8=$GET(^AUPNVSIT(VISIEN,800))
2 ;check for required contaminants in associated encounter
+1 SET PCEIEN=$ORDER(^SCE("AVSIT",VISIEN,0))
IF PCEIEN=""
GOTO 1
+2 SET PCE0=$GET(^SCE(PCEIEN,0))
IF PCE0=""
GOTO 1
+3 IF $PIECE(PCE0,U,12)'=14
GOTO 1
EVAL ;beginning of evaluation criteria for 'action required'
+1 SET SDOE=PCEIEN
+2 SET SDOE0=$$GETOE^SDOE(SDOE)
SET SDIV=$PIECE(SDOE0,U,11)
+3 DO DEM^VADPT
MERGE SDDPT=VADM
+4 KILL SDX
DO CLASK^SDCO2(PCEIEN,.SDX)
+5 IF '$DATA(SDX)
GOTO 1
+6 SET SDI=0
SET ERR=0
SET SDXX=""
FOR
SET SDI=$ORDER(SDX(SDI))
if 'SDI
QUIT
IF $PIECE(SDX(SDI),U,2)=""
SET SDX=""
Begin DoDot:1
+7 ;W !,SDX Q
IF '$DATA(^SD(409.41,SDI,0))
SET SDX="Classification required"
if '$DATA(TOT(SDI))
SET TOT(SDI)=0
SET TOT(SDI)=TOT(SDI)+1
QUIT
+8 ;W !,SDX
SET SDX=$PIECE($GET(^SD(409.41,SDI,0)),U,1)_" classification required"
if '$DATA(TOT(SDI))
SET TOT(SDI)=0
SET TOT(SDI)=TOT(SDI)+1
End DoDot:1
IF SDX'=""
SET ERR=1
SET ^XTMP("RMPR145P",660,IEN,99,SDI)=SDX(SDI)_U_SDX
SET SDXX=SDXX_U_SDI
+9 IF ERR=1
SET TOT=TOT+1
Begin DoDot:1
+10 SET ^XTMP("RMPR145P",660,IEN,10)=R
+11 SET ^XTMP("RMPR145P",660,IEN,10)=R10
+12 SET ^XTMP("RMPR145P",660,IEN,11)=RV
+13 SET ^XTMP("RMPR145P",660,IEN,12)=RV8
+14 SET ^XTMP("RMPR145P",660,IEN,13)=PCE0
+15 ;W !!,IEN,?15,PNAME,!,R,!,R10,!,VISIEN,!,RV,!,RV8,!,PCEIEN,!,PCE0,!,SDXX
+16 FOR I=1:1:7
IF $PIECE(RV8,U,I)=""
SET XX=80000+I
SET DA=VISIEN
SET DR=XX_"////^S X=0"
SET DIE="^AUPNVSIT("
DO ^DIE
+17 SET DA=PCEIEN
SET DR=".12////^S X=2"
SET DIE="^SCE("
DO ^DIE
End DoDot:1
+18 GOTO 1
EXIT ;
+1 ;S II=0 W !
+2 ;F S II=$O(TOT(II)) Q:II="" D
+3 ;. S ENM=$P($G(^SD(409.41,II,0)),U)
+4 ;. W !,ENM," classification required",?50,TOT(II)
+5 ;W !!,"TOTAL 'ACTION REQUIRED' ENCOUNTERS CORRECTED: ",TOT
+6 DO NOW^%DTC
SET RMEND=%
+7 MERGE ^XTMP("RMPR145P","ERRS")=TOT
+8 SET ^XTMP("RMPR145P","END COMPILE")=RMEND
+9 KILL RMEND,RMSTART,IEN,XX,TOT,R,R10,DFN,PCEIEN,VISIEN,PNAME,RV,RV8,PCE0,SDOE,SDOE0,SDIV,VADM,SDDPT,SDX,SDI
+10 KILL ERR,SDXX,TOT,I,DA,DR,DIE,II,ENM
+11 QUIT
