ADEGRL5A ; IHS/HQT/MJL - CODE EDITS ; [ 03/24/1999 9:04 AM ]
;;6.0;ADE;**23**;JUN 6, 2011
;IHS/HMW 10-31-91 HAPPY HALLOWEEN
;INPUTS - ADEV(ADECOD),ADEHX ARRAY
;$O THRU ^ADEDIT("AC",ADECOD,RESOLUTION TYPE,ENTRY NUMBER)
;DO SUBR CORRESPONDING TO EDIT TYPE - RESOLVE PRN
;OUTPUT - FLAG ON ADA CODE, REJECT ADA CODE, REPLACE ADA CODE
;
;FHL 9/9/98 B
CTRL N ADERTYP,ADERDFN,ADENOD,ADEDTYP,ADECONF,ADELIM,ADEJJ,ADEVFM,ADEPC
G:'$D(^ADEDIT("AC",ADECOD)) EXIT
RES ;$O THRU RESOLUTION TYPE XREF
S ADERTYP=0
F S ADERTYP=$O(^ADEDIT("AC",ADECOD,ADERTYP)) Q:'+ADERTYP D RES1 Q:'$D(ADEV(ADECOD))
EXIT Q
K ADERTYP,ADERDFN,ADENOD,ADEDTYP,ADECONF,ADELIM,ADEJJ,ADEVFM,ADEPC ;*NE
K ADEKK ;*NE
;
RES1 S ADERDFN=0
F S ADERDFN=$O(^ADEDIT("AC",ADECOD,ADERTYP,ADERDFN)) Q:'+ADERDFN Q:'$D(ADEV(ADECOD)) D EDIT Q:'$D(ADEV(ADECOD))
Q
EDIT S ADENOD=^ADEDIT(ADERDFN,0)
Q:$P(ADENOD,U,4)="n" ;FHL 9/9/98 ;edit not enabled
S ADEDTYP=$P(ADENOD,U,2)
I ADEDTYP=1 D E1
I ADEDTYP=2 D E2
I ADEDTYP=3 D E3
I ADEDTYP=4 D E4
Q
E1 ;EDIT TYPE 1 -- INCOMPATIBLE CODES
N ADEK,ADEPC,ADEVFM,ADEOP,ADEOPC,ADEKK
;FIRST GET LIST OF CODES
S ADECONF=^ADEDIT(ADERDFN,1)
I ADECONF["[" S ADECONF=$P(ADECONF,"[",2),ADECONF=^ADEDIT("GRP",$O(^ADEDIT("GRP","B",ADECONF,0)),1) ;W "ADECONF=",ADECONF H 1
;SEE IF CURRENT CODE ADECOD IS IN LIST - IF SO, RESOLVE
I $P(^ADEDIT(ADERDFN,0),U,3)]"" D E1A ;Opsite specific
I $P(^ADEDIT(ADERDFN,0),U,3)="" D E1B
Q
E1A F ADEKK=1:1:$L(ADECONF,"|") I $D(ADEV($P(ADECONF,"|",ADEKK))),$P(ADECONF,"|",ADEKK)'=ADECOD D
. F Q:'$D(ADEV(ADECOD)) S ADEOP=$P(ADEV(ADECOD),U,2) S ADEPC=ADEOP_","_$P(ADEV($P(ADECONF,"|",ADEKK)),U,2) S ADEOPC=$$DUPE^ADEGRL5C(ADEPC) Q:'ADEOPC D RESOLVE^ADEGRL5B
Q
E1B S ADEJJ=0 F S ADEJJ=$O(ADEV(ADEJJ)) Q:ADEJJ="" I ADECOD'=ADEJJ,ADECONF[ADEJJ D RESOLVE^ADEGRL5B Q
Q
E2 ;EDIT TYPE 2 -- TIME LIMIT ON CODES
N ADEK,ADEPC,ADEVFM,ADEOP,ADEOPC,ADEKK,ADEQTY
S ADECONF=^ADEDIT(ADERDFN,1)
I ADECONF["[" S ADECONF=$P(ADECONF,"[",2),ADECONF=^ADEDIT("GRP",$O(^ADEDIT("GRP","B",ADECONF,0)),1)
S X=ADEVDATE,%DT="T" D ^%DT S (ADEVFM,X1)=Y K %DT,X,Y ;IHS/HMW **2**
S X2=$P(^ADEDIT(ADERDFN,2),U)
S X2=$TR(X2,"|",";") ;Delimiter may be | or ;
S ADEQTY=$P(X2,";",2),X2=$P(X2,";")
I X2="FY" D
. ;Set ADELIM to beginning of FY
. S ADELIM=$$FY^ADEUTL(ADEVDATE)
E D
. S X2=-X2
. D C^%DTC S ADELIM=X K X
;
;$O THRU ADEHXC & SEE IF ANY OF THESE CODES HAVE DATES AFTER LIMIT TIME
I $P(^ADEDIT(ADERDFN,0),U,3)]"" D E2A ;Opsite specific
I $P(^ADEDIT(ADERDFN,0),U,3)="" D E2B
Q
E2A ;
S ADEOP=$P(ADEV(ADECOD),U,2)
F ADEK=1:1:$L(ADEOP,",") S ADEOPC=$P(ADEOP,",",ADEK) D E2A2 ;Q:$D(ADEXFLG)
Q
E2A2 F ADEKK=1:1:$L(ADECONF,"|") S ADEPC=$P(ADECONF,"|",ADEKK) I $D(ADEHXO(ADEOPC,ADEPC)),$O(ADEHXO(ADEOPC,ADEPC,ADELIM))]"",$O(ADEHXO(ADEOPC,ADEPC,ADELIM))<ADEVFM D E2A3 Q
Q
E2A3 N ADECNT,ADED
S ADECNT=0,ADED=ADELIM
F S ADED=$O(ADEHXO(ADEOPC,ADEPC,ADED)) Q:'+ADED Q:ADED>ADEVFM S ADECNT=ADECNT+1
I ADECNT>(ADEQTY-1) D RESOLVE^ADEGRL5B
Q
E2B F ADEK=1:1:$L(ADECONF,"|") S ADEPC=$P(ADECONF,"|",ADEK) I $D(ADEHXC(ADEPC)),$O(ADEHXC(ADEPC,ADELIM))]"",$O(ADEHXC(ADEPC,ADELIM))<ADEVFM D RESOLVE^ADEGRL5B Q
Q
;
E3 ;Age Screen
N ADEOP,ADEK,ADEPC,ADEOPC,ADETST
;FHL 9/9/98 B
S ADETST=$P(^ADEDIT(ADERDFN,2),U,4)
;I @((AUPNDAYS\365.25)_"'"_$P(^ADEDIT(ADERDFN,2),U,4)) Q
I $E(ADETST,1,1)=">"!($E(ADETST,1,1)="<") S ADETST="'(X"_ADETST_")"
S X=AUPNDAYS\365.25
I @ADETST Q
;
I $P(^ADEDIT(ADERDFN,0),U,3)]"" D E3A ;Opsite specific
I $P(^ADEDIT(ADERDFN,0),U,3)="" D RESOLVE^ADEGRL5B
Q
E3A S ADEOP=$P(ADEV(ADECOD),U,2)
F ADEK=1:1:$L(ADEOP,",") S ADEOPC=$P(ADEOP,",",ADEK) D RESOLVE^ADEGRL5B
Q
E4 ;Permissible Opsites -use only with codes that require opsites
; and use only Resolution 1 (reject)
N ADEPERM,ADEK,ADEOP,ADEOPC
S ADEPERM=$P(^ADEDIT(ADERDFN,4),U)
I ADEPERM["[" S ADEPERM=$P(ADEPERM,"[",2),ADEPERM=$O(^ADEDIT("GRP","B",ADEPERM,0)),ADEPERM=$P(^ADEDIT("GRP",ADEPERM,1),U)
F ADEK=1:1:$L(ADEPERM,"|") D
. S ADEPC=$P(ADEPERM,"|",ADEK)
. S ADEPC=$O(^ADEOPS("B",ADEPC,0))
. S:ADEPC ADEPERM(ADEPC)=""
S ADEOP=$P(ADEV(ADECOD),U,2)
Q:'ADEOP ;IHS;SD;TPF H31091 PATCH 23
F ADEK=1:1:$L(ADEOP,",") S ADEOPC=$P(ADEOP,",",ADEK) D
. I '$D(ADEPERM(ADEOPC)) D RESOLVE^ADEGRL5B
Q
K ADEPERM ;*NE
ADEGRL5A ; IHS/HQT/MJL - CODE EDITS ; [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;**23**;JUN 6, 2011
+2 ;IHS/HMW 10-31-91 HAPPY HALLOWEEN
+3 ;INPUTS - ADEV(ADECOD),ADEHX ARRAY
+4 ;$O THRU ^ADEDIT("AC",ADECOD,RESOLUTION TYPE,ENTRY NUMBER)
+5 ;DO SUBR CORRESPONDING TO EDIT TYPE - RESOLVE PRN
+6 ;OUTPUT - FLAG ON ADA CODE, REJECT ADA CODE, REPLACE ADA CODE
+7 ;
+8 ;FHL 9/9/98 B
CTRL NEW ADERTYP,ADERDFN,ADENOD,ADEDTYP,ADECONF,ADELIM,ADEJJ,ADEVFM,ADEPC
+1 IF '$DATA(^ADEDIT("AC",ADECOD))
GOTO EXIT
RES ;$O THRU RESOLUTION TYPE XREF
+1 SET ADERTYP=0
+2 FOR
SET ADERTYP=$ORDER(^ADEDIT("AC",ADECOD,ADERTYP))
IF '+ADERTYP
QUIT
DO RES1
IF '$DATA(ADEV(ADECOD))
QUIT
EXIT QUIT
+1 ;*NE
KILL ADERTYP,ADERDFN,ADENOD,ADEDTYP,ADECONF,ADELIM,ADEJJ,ADEVFM,ADEPC
+2 ;*NE
KILL ADEKK
+3 ;
RES1 SET ADERDFN=0
+1 FOR
SET ADERDFN=$ORDER(^ADEDIT("AC",ADECOD,ADERTYP,ADERDFN))
IF '+ADERDFN
QUIT
IF '$DATA(ADEV(ADECOD))
QUIT
DO EDIT
IF '$DATA(ADEV(ADECOD))
QUIT
+2 QUIT
EDIT SET ADENOD=^ADEDIT(ADERDFN,0)
+1 ;FHL 9/9/98 ;edit not enabled
IF $PIECE(ADENOD,U,4)="n"
QUIT
+2 SET ADEDTYP=$PIECE(ADENOD,U,2)
+3 IF ADEDTYP=1
DO E1
+4 IF ADEDTYP=2
DO E2
+5 IF ADEDTYP=3
DO E3
+6 IF ADEDTYP=4
DO E4
+7 QUIT
E1 ;EDIT TYPE 1 -- INCOMPATIBLE CODES
+1 NEW ADEK,ADEPC,ADEVFM,ADEOP,ADEOPC,ADEKK
+2 ;FIRST GET LIST OF CODES
+3 SET ADECONF=^ADEDIT(ADERDFN,1)
+4 ;W "ADECONF=",ADECONF H 1
IF ADECONF["["
SET ADECONF=$PIECE(ADECONF,"[",2)
SET ADECONF=^ADEDIT("GRP",$ORDER(^ADEDIT("GRP","B",ADECONF,0)),1)
+5 ;SEE IF CURRENT CODE ADECOD IS IN LIST - IF SO, RESOLVE
+6 ;Opsite specific
IF $PIECE(^ADEDIT(ADERDFN,0),U,3)]""
DO E1A
+7 IF $PIECE(^ADEDIT(ADERDFN,0),U,3)=""
DO E1B
+8 QUIT
E1A FOR ADEKK=1:1:$LENGTH(ADECONF,"|")
IF $DATA(ADEV($PIECE(ADECONF,"|",ADEKK)))
IF $PIECE(ADECONF,"|",ADEKK)'=ADECOD
Begin DoDot:1
+1 FOR
IF '$DATA(ADEV(ADECOD))
QUIT
SET ADEOP=$PIECE(ADEV(ADECOD),U,2)
SET ADEPC=ADEOP_","_$PIECE(ADEV($PIECE(ADECONF,"|",ADEKK)),U,2)
SET ADEOPC=$$DUPE^ADEGRL5C(ADEPC)
IF 'ADEOPC
QUIT
DO RESOLVE^ADEGRL5B
End DoDot:1
+2 QUIT
E1B SET ADEJJ=0
FOR
SET ADEJJ=$ORDER(ADEV(ADEJJ))
IF ADEJJ=""
QUIT
IF ADECOD'=ADEJJ
IF ADECONF[ADEJJ
DO RESOLVE^ADEGRL5B
QUIT
+1 QUIT
E2 ;EDIT TYPE 2 -- TIME LIMIT ON CODES
+1 NEW ADEK,ADEPC,ADEVFM,ADEOP,ADEOPC,ADEKK,ADEQTY
+2 SET ADECONF=^ADEDIT(ADERDFN,1)
+3 IF ADECONF["["
SET ADECONF=$PIECE(ADECONF,"[",2)
SET ADECONF=^ADEDIT("GRP",$ORDER(^ADEDIT("GRP","B",ADECONF,0)),1)
+4 ;IHS/HMW **2**
SET X=ADEVDATE
SET %DT="T"
DO ^%DT
SET (ADEVFM,X1)=Y
KILL %DT,X,Y
+5 SET X2=$PIECE(^ADEDIT(ADERDFN,2),U)
+6 ;Delimiter may be | or ;
SET X2=$TRANSLATE(X2,"|",";")
+7 SET ADEQTY=$PIECE(X2,";",2)
SET X2=$PIECE(X2,";")
+8 IF X2="FY"
Begin DoDot:1
+9 ;Set ADELIM to beginning of FY
+10 SET ADELIM=$$FY^ADEUTL(ADEVDATE)
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 SET X2=-X2
+13 DO C^%DTC
SET ADELIM=X
KILL X
End DoDot:1
+14 ;
+15 ;$O THRU ADEHXC & SEE IF ANY OF THESE CODES HAVE DATES AFTER LIMIT TIME
+16 ;Opsite specific
IF $PIECE(^ADEDIT(ADERDFN,0),U,3)]""
DO E2A
+17 IF $PIECE(^ADEDIT(ADERDFN,0),U,3)=""
DO E2B
+18 QUIT
E2A ;
+1 SET ADEOP=$PIECE(ADEV(ADECOD),U,2)
+2 ;Q:$D(ADEXFLG)
FOR ADEK=1:1:$LENGTH(ADEOP,",")
SET ADEOPC=$PIECE(ADEOP,",",ADEK)
DO E2A2
+3 QUIT
E2A2 FOR ADEKK=1:1:$LENGTH(ADECONF,"|")
SET ADEPC=$PIECE(ADECONF,"|",ADEKK)
IF $DATA(ADEHXO(ADEOPC,ADEPC))
IF $ORDER(ADEHXO(ADEOPC,ADEPC,ADELIM))]""
IF $ORDER(ADEHXO(ADEOPC,ADEPC,ADELIM))<ADEVFM
DO E2A3
QUIT
+1 QUIT
E2A3 NEW ADECNT,ADED
+1 SET ADECNT=0
SET ADED=ADELIM
+2 FOR
SET ADED=$ORDER(ADEHXO(ADEOPC,ADEPC,ADED))
IF '+ADED
QUIT
IF ADED>ADEVFM
QUIT
SET ADECNT=ADECNT+1
+3 IF ADECNT>(ADEQTY-1)
DO RESOLVE^ADEGRL5B
+4 QUIT
E2B FOR ADEK=1:1:$LENGTH(ADECONF,"|")
SET ADEPC=$PIECE(ADECONF,"|",ADEK)
IF $DATA(ADEHXC(ADEPC))
IF $ORDER(ADEHXC(ADEPC,ADELIM))]""
IF $ORDER(ADEHXC(ADEPC,ADELIM))<ADEVFM
DO RESOLVE^ADEGRL5B
QUIT
+1 QUIT
+2 ;
E3 ;Age Screen
+1 NEW ADEOP,ADEK,ADEPC,ADEOPC,ADETST
+2 ;FHL 9/9/98 B
+3 SET ADETST=$PIECE(^ADEDIT(ADERDFN,2),U,4)
+4 ;I @((AUPNDAYS\365.25)_"'"_$P(^ADEDIT(ADERDFN,2),U,4)) Q
+5 IF $EXTRACT(ADETST,1,1)=">"!($EXTRACT(ADETST,1,1)="<")
SET ADETST="'(X"_ADETST_")"
+6 SET X=AUPNDAYS\365.25
+7 IF @ADETST
QUIT
+8 ;
+9 ;Opsite specific
IF $PIECE(^ADEDIT(ADERDFN,0),U,3)]""
DO E3A
+10 IF $PIECE(^ADEDIT(ADERDFN,0),U,3)=""
DO RESOLVE^ADEGRL5B
+11 QUIT
E3A SET ADEOP=$PIECE(ADEV(ADECOD),U,2)
+1 FOR ADEK=1:1:$LENGTH(ADEOP,",")
SET ADEOPC=$PIECE(ADEOP,",",ADEK)
DO RESOLVE^ADEGRL5B
+2 QUIT
E4 ;Permissible Opsites -use only with codes that require opsites
+1 ; and use only Resolution 1 (reject)
+2 NEW ADEPERM,ADEK,ADEOP,ADEOPC
+3 SET ADEPERM=$PIECE(^ADEDIT(ADERDFN,4),U)
+4 IF ADEPERM["["
SET ADEPERM=$PIECE(ADEPERM,"[",2)
SET ADEPERM=$ORDER(^ADEDIT("GRP","B",ADEPERM,0))
SET ADEPERM=$PIECE(^ADEDIT("GRP",ADEPERM,1),U)
+5 FOR ADEK=1:1:$LENGTH(ADEPERM,"|")
Begin DoDot:1
+6 SET ADEPC=$PIECE(ADEPERM,"|",ADEK)
+7 SET ADEPC=$ORDER(^ADEOPS("B",ADEPC,0))
+8 IF ADEPC
SET ADEPERM(ADEPC)=""
End DoDot:1
+9 SET ADEOP=$PIECE(ADEV(ADECOD),U,2)
+10 ;IHS;SD;TPF H31091 PATCH 23
IF 'ADEOP
QUIT
+11 FOR ADEK=1:1:$LENGTH(ADEOP,",")
SET ADEOPC=$PIECE(ADEOP,",",ADEK)
Begin DoDot:1
+12 IF '$DATA(ADEPERM(ADEOPC))
DO RESOLVE^ADEGRL5B
End DoDot:1
+13 QUIT
+14 ;*NE
KILL ADEPERM
