- PSDCOR3 ;BIR/JPW-CS Correction Action (cont'd) ; 22 May 93
- ;;3.0; CONTROLLED SUBSTANCES ;**66**;13 Feb 97;Build 3
- COM ;complete correction
- S CPBYD=+$P(NODE,"^",19)
- F L +^PSD(58.87,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
- FIND S PSDCOR=$P(^PSD(58.87,0),"^",3)+1 I $D(^PSD(58.87,PSDCOR)) S $P(^PSD(58.87,0),"^",3)=PSDCOR G FIND
- K DA,DIC,DLAYGO S (DIC,DLAYGO)=58.87,DIC(0)="L",X=PSDCOR D ^DIC K DIC,DLAYGO
- L -^PSD(58.87,0)
- K DA,DIE,DR S DIE=58.87,DA=PSDCOR,DR="1////"_RECDT_";2////"_PSDUZ_";3////"_PSDPN_";4////"_PSDR_";5////"_NAOU_";7////"_CPBYD_";8////"_ORD_";9////"_CPBY_";11////"_TYPE_";12////"_PSDS_";13////"_OCOMP_";14////"_COMP
- D ^DIE K DA,DIE,DR
- END K CPBY,CPBYD,PSDCOR
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDCOR3 697 printed Feb 18, 2025@23:11:40 Page 2
- PSDCOR3 ;BIR/JPW-CS Correction Action (cont'd) ; 22 May 93
- +1 ;;3.0; CONTROLLED SUBSTANCES ;**66**;13 Feb 97;Build 3
- COM ;complete correction
- +1 SET CPBYD=+$PIECE(NODE,"^",19)
- +2 FOR
- LOCK +^PSD(58.87,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- QUIT
- FIND SET PSDCOR=$PIECE(^PSD(58.87,0),"^",3)+1
- IF $DATA(^PSD(58.87,PSDCOR))
- SET $PIECE(^PSD(58.87,0),"^",3)=PSDCOR
- GOTO FIND
- +1 KILL DA,DIC,DLAYGO
- SET (DIC,DLAYGO)=58.87
- SET DIC(0)="L"
- SET X=PSDCOR
- DO ^DIC
- KILL DIC,DLAYGO
- +2 LOCK -^PSD(58.87,0)
- +3 KILL DA,DIE,DR
- SET DIE=58.87
- SET DA=PSDCOR
- SET DR="1////"_RECDT_";2////"_PSDUZ_";3////"_PSDPN_";4////"_PSDR_";5////"_NAOU_";7////"_CPBYD_";8////"_ORD_";9////"_CPBY_";11////"_TYPE_";12////"_PSDS_";13////"_OCOMP_";14////"_COMP
- +4 DO ^DIE
- KILL DA,DIE,DR
- END KILL CPBY,CPBYD,PSDCOR
- +1 QUIT
