- PXKMOD ;ISA/KWP -MAIN ROUTINE FOR SAVING MODIFIERS ;10/11/2018
- ;;1.0;PCE PATIENT CARE ENCOUNTER;**73,121,211**;Aug 12, 1996;Build 454
- SUBSCR ;
- AFTER N PXKMOD
- S PXKMOD=""
- F S PXKMOD=$O(@PXKREF@(PXKCAT,PXKSEQ,PXKSUB,PXKMOD)) Q:'PXKMOD D
- . S PXKAFT(1,PXKMOD)=$G(@PXKREF@(PXKCAT,PXKSEQ,PXKSUB,PXKMOD,"AFTER"))
- BEFORE S PXKMOD=""
- F S PXKMOD=$O(@PXKREF@(PXKCAT,PXKSEQ,PXKSUB,PXKMOD)) Q:'PXKMOD D
- . S PXKBEF(1,PXKMOD)=$G(@PXKREF@(PXKCAT,PXKSEQ,PXKSUB,PXKMOD,"BEFORE"))
- Q
- UPD(PXKPIEN) ;Add a modifier
- N PXKMOD,PXRETVAL,PXKMIEN
- S PXKMOD=""
- F S PXKMOD=$O(PXKAV(1,PXKMOD)) Q:PXKMOD="" D
- .S PXKMIEN=PXKAV(1,PXKMOD)
- .;If the modifier is already present do not add it again.
- .I $D(^AUPNVCPT(PXKPIEN,1,"B",PXKMIEN)) Q
- .S PXRETVAL=$$ADD(PXKPIEN,PXKMIEN)
- Q
- LOOP N PXKMOD
- S PXKMOD=""
- F S PXKMOD=$O(PXKAFT(1,PXKMOD)) Q:PXKMOD="" D
- . Q:PXKAFT(1,PXKMOD)=""
- . S PXKAV(1,PXKMOD)=PXKAFT(1,PXKMOD)
- S PXKMOD=""
- F S PXKMOD=$O(PXKBEF(1,PXKMOD)) Q:PXKMOD="" D
- . Q:PXKBEF(1,PXKMOD)=""
- . S PXKBV(1,PXKMOD)=PXKBEF(1,PXKMOD)
- Q
- DELETE(IEN) ;
- N DIE,DR,SIEN,DA
- S DIE="^AUPNVCPT("_IEN_",1,",DR=".01////@",SIEN=0
- F S SIEN=$O(^AUPNVCPT(IEN,1,SIEN)) Q:SIEN="" S DA=SIEN,DA(1)=IEN D ^DIE
- Q 1
- ADD(IEN,PXKMOD) ;
- N DA,DIC,DO,X
- S DIC="^AUPNVCPT("_IEN_",1,"
- S DIC("P")=$P($G(^DD(+$P($G(^AUPNVCPT(0)),"^",2),1,0)),"^",2)
- S DA(1)=IEN
- S DIC(0)="L"
- S PXKMOD=$P($$MOD^ICPTMOD(PXKMOD,"I",+^TMP("PXK",$J,"VST",1,0,"AFTER")),"^")
- I PXKMOD<0 Q 0
- S X=PXKMOD
- D FILE^DICN
- Q 1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXKMOD 1514 printed Feb 18, 2025@23:55:49 Page 2
- PXKMOD ;ISA/KWP -MAIN ROUTINE FOR SAVING MODIFIERS ;10/11/2018
- +1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**73,121,211**;Aug 12, 1996;Build 454
- SUBSCR ;
- AFTER NEW PXKMOD
- +1 SET PXKMOD=""
- +2 FOR
- SET PXKMOD=$ORDER(@PXKREF@(PXKCAT,PXKSEQ,PXKSUB,PXKMOD))
- if 'PXKMOD
- QUIT
- Begin DoDot:1
- +3 SET PXKAFT(1,PXKMOD)=$GET(@PXKREF@(PXKCAT,PXKSEQ,PXKSUB,PXKMOD,"AFTER"))
- End DoDot:1
- BEFORE SET PXKMOD=""
- +1 FOR
- SET PXKMOD=$ORDER(@PXKREF@(PXKCAT,PXKSEQ,PXKSUB,PXKMOD))
- if 'PXKMOD
- QUIT
- Begin DoDot:1
- +2 SET PXKBEF(1,PXKMOD)=$GET(@PXKREF@(PXKCAT,PXKSEQ,PXKSUB,PXKMOD,"BEFORE"))
- End DoDot:1
- +3 QUIT
- UPD(PXKPIEN) ;Add a modifier
- +1 NEW PXKMOD,PXRETVAL,PXKMIEN
- +2 SET PXKMOD=""
- +3 FOR
- SET PXKMOD=$ORDER(PXKAV(1,PXKMOD))
- if PXKMOD=""
- QUIT
- Begin DoDot:1
- +4 SET PXKMIEN=PXKAV(1,PXKMOD)
- +5 ;If the modifier is already present do not add it again.
- +6 IF $DATA(^AUPNVCPT(PXKPIEN,1,"B",PXKMIEN))
- QUIT
- +7 SET PXRETVAL=$$ADD(PXKPIEN,PXKMIEN)
- End DoDot:1
- +8 QUIT
- LOOP NEW PXKMOD
- +1 SET PXKMOD=""
- +2 FOR
- SET PXKMOD=$ORDER(PXKAFT(1,PXKMOD))
- if PXKMOD=""
- QUIT
- Begin DoDot:1
- +3 if PXKAFT(1,PXKMOD)=""
- QUIT
- +4 SET PXKAV(1,PXKMOD)=PXKAFT(1,PXKMOD)
- End DoDot:1
- +5 SET PXKMOD=""
- +6 FOR
- SET PXKMOD=$ORDER(PXKBEF(1,PXKMOD))
- if PXKMOD=""
- QUIT
- Begin DoDot:1
- +7 if PXKBEF(1,PXKMOD)=""
- QUIT
- +8 SET PXKBV(1,PXKMOD)=PXKBEF(1,PXKMOD)
- End DoDot:1
- +9 QUIT
- DELETE(IEN) ;
- +1 NEW DIE,DR,SIEN,DA
- +2 SET DIE="^AUPNVCPT("_IEN_",1,"
- SET DR=".01////@"
- SET SIEN=0
- +3 FOR
- SET SIEN=$ORDER(^AUPNVCPT(IEN,1,SIEN))
- if SIEN=""
- QUIT
- SET DA=SIEN
- SET DA(1)=IEN
- DO ^DIE
- +4 QUIT 1
- ADD(IEN,PXKMOD) ;
- +1 NEW DA,DIC,DO,X
- +2 SET DIC="^AUPNVCPT("_IEN_",1,"
- +3 SET DIC("P")=$PIECE($GET(^DD(+$PIECE($GET(^AUPNVCPT(0)),"^",2),1,0)),"^",2)
- +4 SET DA(1)=IEN
- +5 SET DIC(0)="L"
- +6 SET PXKMOD=$PIECE($$MOD^ICPTMOD(PXKMOD,"I",+^TMP("PXK",$JOB,"VST",1,0,"AFTER")),"^")
- +7 IF PXKMOD<0
- QUIT 0
- +8 SET X=PXKMOD
- +9 DO FILE^DICN
- +10 QUIT 1
