- ACGSEDIT ;IHS/OIRM/DSD/THL - EDIT CONTRACT/CONTRACT ACTION; [ 03/27/2000 2:22 PM ]
- ;;2.0t1;CONTRACT INFORMATION SYSTEM;;FEB 16, 2000
- ;;ROUTINE WHICH IS CALLED TO EDIT CONTRACT/CONTRACT ACTION
- EN K ACGNEW
- F D EDIT Q:$D(ACGQUIT)!$D(ACGOUT)
- EXIT K ACG,ACGN,ACGJ,ACGI,ACGQUIT,ACGTOT,ACGFLDS,ACGFLDSS,ACGCNO,ACGRDA,ACGOUT,ACGXX
- Q
- EDIT D VND^ACGSTAR1:'$D(ACGOUT)
- Q:$D(ACGQUIT)!$D(ACGOUT)!'$D(ACG5DA)
- F D EDIT1 Q:$D(ACGQUIT)
- K ACGQUIT
- Q
- EDIT1 ;EP;TO SELECT CONTRACT OR MODIFICATION TO EDIT
- Q:'$D(ACGCNO)
- W !!?13,"CONTRACT/",!,"NO.",?5,"TYPE",?11,"MODIFICATION",?30,"AMOUNT",!,"---",?5,"----",?11,"--------------",?27,"------------ --------------------------------------"
- S (ACG,ACGJ,ACGTOT)=0
- F S ACG=$O(^ACGS("C",ACGCNO,ACG)) Q:'ACG I $D(^ACGS(ACG,0)),$D(^("DT")) S ACGDT=^("DT") D
- .S ACGJ=ACGJ+1,ACGXX($P(ACGDT,U,2),ACGJ)=ACG
- S ACG="",ACGI=0
- F S ACG=$O(ACGXX(ACG)) Q:ACG="" D
- .S ACGJ=0
- .F S ACGJ=$O(ACGXX(ACG,ACGJ)) Q:'ACGJ S ACGI=ACGI+1,ACG(ACGI-1)=ACGXX(ACG,ACGJ)
- K ACGXX
- S ACGI=""
- F S ACGI=$O(ACG(ACGI)) Q:ACGI="" D
- .S ACGJ=ACGI
- .S ACG=+ACG(ACGI)
- .Q:'ACG
- .S ACGN=+^ACGS(ACG,0)
- .I ACGN'=ACGJ,"^6^15^17^"'[(U_+^ACGS(ACG,"DT")_U) D COUNT
- .D WEC
- .I ACGJ>1,ACGJ#20=0 D HOLD^ACGSMENU
- I ACGJ<0 W !!,"NO CONTRACT ACTIONS ON FILE FOR THIS CONTRACT" S ACGQUIT="" D HOLD^ACGSMENU Q
- W !?27,"------------",!?18,"TOTAL:",?27,$J($FN(ACGTOT,"P",0),12),!
- I $D(ACGNEW) K ACGNEW Q
- I ACGJ=0 S Y=0 D E1 S ACGQUIT="" Q
- S DIR(0)="NO^0:"_ACGJ,DIR("A")="Which one"
- D DIR^ACGSDIC
- Q:$D(ACGQUIT)!(Y<0)
- E1 Q:'$D(ACG(Y))
- S ACGRDA=ACG(Y),(ACGFLDS,ACGFLDSS)=$P(^ACGTPA($P(^ACGS(ACGRDA,"DT"),U),0),U)
- I '$D(ACGFY),'ACGFY S ACGFY=91
- I $P(^ACGS(ACGRDA,0),U,4)'="" W *7,*7,!!,"THIS RECORD HAS ALREADY BEEN EXPORTED AND CANNOT BE EDITED" Q
- I $D(ACGDELET) D Q
- .I $P(^ACGS(ACGRDA,0),U,3)=ACGRDA W *7,*7,!!,"ORIGINAL CONTRACT ACTION CANNOT BE DELETED." Q
- .S ACG=ACGRDA D WEC S DIR(0)="YO",DIR("A")="Sure you want to delete this modification",DIR("B")="NO" W ! D DIR^ACGSDIC Q:$D(ACGQUIT)!(+Y'=1) S DA=ACGRDA,DIK="^ACGS(" D ^DIK
- D ^ACGSCS
- Q
- COUNT S ACG2=$P(^ACGS(ACG,"DT"),U,2),DIE="^ACGS(",DA=ACG,DR=".01////"_ACGJ S:$E(ACG2,$L(ACGJ),$L(ACG2))'=ACGJ ACG2=$E(ACG2,1,$L(ACG2)-$L(ACGJ))_ACGJ,DR=DR_";2////"_ACG2_";1099////"_DT D DIE^ACGSDIC
- Q
- WEC Q:'$D(^ACGS(ACG,"DT"))!'$D(^("DT1"))
- S ACGDT=^ACGS(ACG,"DT"),ACGDT1=^("DT1")
- W !,ACGJ,?6,$P(^ACGTPA(+ACGDT,0),U),?11,$S("^15^17^"'[(U_+ACGDT_U):$P(^ACGS(ACG,"DT"),U,2),1:$P(^ACGS(ACG,"SP"),U)),?27,$J($FN($P(ACGDT1,U,5),"P",0),12),?41,$S("^15^17^"'[(U_+ACGDT_U):$E($P(ACGDT1,U),1,38),1:"SMALL PURCHASE")
- S ACGTOT=ACGTOT+$P(^ACGS(ACG,"DT1"),U,5)
- ;PATCH XX
- Q
- ACGSEDIT ;IHS/OIRM/DSD/THL - EDIT CONTRACT/CONTRACT ACTION; [ 03/27/2000 2:22 PM ]
- +1 ;;2.0t1;CONTRACT INFORMATION SYSTEM;;FEB 16, 2000
- +2 ;;ROUTINE WHICH IS CALLED TO EDIT CONTRACT/CONTRACT ACTION
- EN KILL ACGNEW
- +1 FOR
- DO EDIT
- IF $DATA(ACGQUIT)!$DATA(ACGOUT)
- QUIT
- EXIT KILL ACG,ACGN,ACGJ,ACGI,ACGQUIT,ACGTOT,ACGFLDS,ACGFLDSS,ACGCNO,ACGRDA,ACGOUT,ACGXX
- +1 QUIT
- EDIT IF '$DATA(ACGOUT)
- DO VND^ACGSTAR1
- +1 IF $DATA(ACGQUIT)!$DATA(ACGOUT)!'$DATA(ACG5DA)
- QUIT
- +2 FOR
- DO EDIT1
- IF $DATA(ACGQUIT)
- QUIT
- +3 KILL ACGQUIT
- +4 QUIT
- EDIT1 ;EP;TO SELECT CONTRACT OR MODIFICATION TO EDIT
- +1 IF '$DATA(ACGCNO)
- QUIT
- +2 WRITE !!?13,"CONTRACT/",!,"NO.",?5,"TYPE",?11,"MODIFICATION",?30,"AMOUNT",!,"---",?5,"----",?11,"--------------",?27,"------------ --------------------------------------"
- +3 SET (ACG,ACGJ,ACGTOT)=0
- +4 FOR
- SET ACG=$ORDER(^ACGS("C",ACGCNO,ACG))
- IF 'ACG
- QUIT
- IF $DATA(^ACGS(ACG,0))
- IF $DATA(^("DT"))
- SET ACGDT=^("DT")
- Begin DoDot:1
- +5 SET ACGJ=ACGJ+1
- SET ACGXX($PIECE(ACGDT,U,2),ACGJ)=ACG
- End DoDot:1
- +6 SET ACG=""
- SET ACGI=0
- +7 FOR
- SET ACG=$ORDER(ACGXX(ACG))
- IF ACG=""
- QUIT
- Begin DoDot:1
- +8 SET ACGJ=0
- +9 FOR
- SET ACGJ=$ORDER(ACGXX(ACG,ACGJ))
- IF 'ACGJ
- QUIT
- SET ACGI=ACGI+1
- SET ACG(ACGI-1)=ACGXX(ACG,ACGJ)
- End DoDot:1
- +10 KILL ACGXX
- +11 SET ACGI=""
- +12 FOR
- SET ACGI=$ORDER(ACG(ACGI))
- IF ACGI=""
- QUIT
- Begin DoDot:1
- +13 SET ACGJ=ACGI
- +14 SET ACG=+ACG(ACGI)
- +15 IF 'ACG
- QUIT
- +16 SET ACGN=+^ACGS(ACG,0)
- +17 IF ACGN'=ACGJ
- IF "^6^15^17^"'[(U_+^ACGS(ACG,"DT")_U)
- DO COUNT
- +18 DO WEC
- +19 IF ACGJ>1
- IF ACGJ#20=0
- DO HOLD^ACGSMENU
- End DoDot:1
- +20 IF ACGJ<0
- WRITE !!,"NO CONTRACT ACTIONS ON FILE FOR THIS CONTRACT"
- SET ACGQUIT=""
- DO HOLD^ACGSMENU
- QUIT
- +21 WRITE !?27,"------------",!?18,"TOTAL:",?27,$JUSTIFY($FNUMBER(ACGTOT,"P",0),12),!
- +22 IF $DATA(ACGNEW)
- KILL ACGNEW
- QUIT
- +23 IF ACGJ=0
- SET Y=0
- DO E1
- SET ACGQUIT=""
- QUIT
- +24 SET DIR(0)="NO^0:"_ACGJ
- SET DIR("A")="Which one"
- +25 DO DIR^ACGSDIC
- +26 IF $DATA(ACGQUIT)!(Y<0)
- QUIT
- E1 IF '$DATA(ACG(Y))
- QUIT
- +1 SET ACGRDA=ACG(Y)
- SET (ACGFLDS,ACGFLDSS)=$PIECE(^ACGTPA($PIECE(^ACGS(ACGRDA,"DT"),U),0),U)
- +2 IF '$DATA(ACGFY)
- IF 'ACGFY
- SET ACGFY=91
- +3 IF $PIECE(^ACGS(ACGRDA,0),U,4)'=""
- WRITE *7,*7,!!,"THIS RECORD HAS ALREADY BEEN EXPORTED AND CANNOT BE EDITED"
- QUIT
- +4 IF $DATA(ACGDELET)
- Begin DoDot:1
- +5 IF $PIECE(^ACGS(ACGRDA,0),U,3)=ACGRDA
- WRITE *7,*7,!!,"ORIGINAL CONTRACT ACTION CANNOT BE DELETED."
- QUIT
- +6 SET ACG=ACGRDA
- DO WEC
- SET DIR(0)="YO"
- SET DIR("A")="Sure you want to delete this modification"
- SET DIR("B")="NO"
- WRITE !
- DO DIR^ACGSDIC
- IF $DATA(ACGQUIT)!(+Y'=1)
- QUIT
- SET DA=ACGRDA
- SET DIK="^ACGS("
- DO ^DIK
- End DoDot:1
- QUIT
- +7 DO ^ACGSCS
- +8 QUIT
- COUNT SET ACG2=$PIECE(^ACGS(ACG,"DT"),U,2)
- SET DIE="^ACGS("
- SET DA=ACG
- SET DR=".01////"_ACGJ
- IF $EXTRACT(ACG2,$LENGTH(ACGJ),$LENGTH(ACG2))'=ACGJ
- SET ACG2=$EXTRACT(ACG2,1,$LENGTH(ACG2)-$LENGTH(ACGJ))_ACGJ
- SET DR=DR_";2////"_ACG2_";1099////"_DT
- DO DIE^ACGSDIC
- +1 QUIT
- WEC IF '$DATA(^ACGS(ACG,"DT"))!'$DATA(^("DT1"))
- QUIT
- +1 SET ACGDT=^ACGS(ACG,"DT")
- SET ACGDT1=^("DT1")
- +2 WRITE !,ACGJ,?6,$PIECE(^ACGTPA(+ACGDT,0),U),?11,$SELECT("^15^17^"'[(U_+ACGDT_U):$PIECE(^ACGS(ACG,"DT"),U,2),1:$PIECE(^ACGS(ACG,"SP"),U)),?27,$JUSTIFY(...
- ... $FNUMBER($PIECE(ACGDT1,U,5),"P",0),12),?41,$SELECT("^15^17^"'[(U_+ACGDT_U):$EXTRACT($PIECE(ACGDT1,U),1,38),1:"SMALL PURCHASE")
- +3 SET ACGTOT=ACGTOT+$PIECE(^ACGS(ACG,"DT1"),U,5)
- +4 ;PATCH XX
- +5 QUIT
